c-----------------------------------------------------------------------
      subroutine uzawa_gmres(res,h1,h2,h2inv,intype,iter)

c     Solve the pressure equation by right-preconditioned
c     GMRES iteration.
c     intype =  0  (steady)
c     intype =  1  (explicit)
c     intype = -1  (implicit)

      include 'SIZE'
      include 'TOTAL'
      include 'GMRES'
      common  /ctolpr/ divex
      common  /cprint/ ifprint
      logical          ifprint
      real             res  (lx2*ly2*lz2*lelv)
      real             h1   (lx1,ly1,lz1,lelv)
      real             h2   (lx1,ly1,lz1,lelv)
      real             h2inv(lx1,ly1,lz1,lelv)

      common /scrmg/    wp (lx2,ly2,lz2,lelv)

      common /ctmp0/   wk1(lgmres),wk2(lgmres)
      common /cgmres1/ y(lgmres)

      real alpha, l, temp
      integer j,m
c
      logical iflag
      save    iflag
      data    iflag /.false./
      real    norm_fac
      save    norm_fac
c
      real*8 etime1,dnekclock
c
      if(.not.iflag) then
         iflag=.true.
         call uzawa_gmres_split0(ml,mu,bm2,bm2inv,nx2*ny2*nz2*nelv)
         norm_fac = 1./sqrt(volvm2)
      endif
c
      etime1 = dnekclock()
      etime_p = 0.
      divex = 0.
      iter  = 0
      m = lgmres
c
      call chktcg2(tolps,res,iconv)
      if (param(21).gt.0.and.tolps.gt.abs(param(21)))
     $   tolps = abs(param(21))
c     if (param(21).lt.0) tolps = abs(param(21))
      if (istep.eq.0) tolps = 1.e-4
      tolpss = tolps
c
      ntot2  = nx2*ny2*nz2*nelv
c
      iconv = 0
      call rzero(x,ntot2)

      do while(iconv.eq.0.and.iter.lt.100)

         if(iter.eq.0) then
                                                  !      -1
            call col3(r,ml,res,ntot2)             ! r = L  res
c           call copy(r,res,ntot2)
         else
            !update residual
            call copy(r,res,ntot2)                ! r = res
            call cdabdtp(w,x,h1,h2,h2inv,intype)  ! w = A x
            call add2s2(r,w,-1.,ntot2)            ! r = r - w
                                                  !      -1
            call col2(r,ml,ntot2)                 ! r = L   r
         endif
                                                  !            ______
         gamma(1) = sqrt(glsc2(r,r,ntot2))        ! gamma  = \/ (r,r)
                                                  !      1
         if(iter.eq.0) then
            div0 = gamma(1)*norm_fac
            if (param(21).lt.0) tolpss=abs(param(21))*div0
         endif

         !check for lucky convergence
         rnorm = 0.
         if(gamma(1) .eq. 0.) goto 9000
         temp = 1./gamma(1)
         call cmult2(v(1,1),r,temp,ntot2)         ! v  = r / gamma
                                                  !  1            1
         do j=1,m
            iter = iter+1
                                                  !       -1
            call col3(w,mu,v(1,j),ntot2)          ! w  = U   v
                                                  !           j

            etime2 = dnekclock()
            if(param(43).eq.1) then
               call uzprec(z(1,j),w,h1,h2,intype,wp)
            else                                  !       -1
               call hsmg_solve(z(1,j),w)          ! z  = M   w
c              call copy(z(1,j),w,ntot2)          ! z  = M   w
            endif
            etime_p = etime_p + dnekclock()-etime2

            call cdabdtp(w,z(1,j),                ! w = A z
     $                   h1,h2,h2inv,intype)      !        j

                                                  !      -1
            call col2(w,ml,ntot2)                 ! w = L   w

c           !modified Gram-Schmidt
c           do i=1,j
c              h(i,j)=glsc2(w,v(1,i),ntot2)       ! h    = (w,v )
c                                                 !  i,j       i
c              call add2s2(w,v(1,i),-h(i,j),ntot2)! w = w - h    v
c           enddo                                 !          i,j  i

c           2-PASS GS, 1st pass:

            do i=1,j
               h(i,j)=vlsc2(w,v(1,i),ntot2)       ! h    = (w,v )
            enddo                                 !  i,j       i

            call gop(h(1,j),wk1,'+  ',j)          ! sum over P procs

            do i=1,j
               call add2s2(w,v(1,i),-h(i,j),ntot2)! w = w - h    v
            enddo                                 !          i,j  i

c           2-PASS GS, 2nd pass:
c
c           do i=1,j
c              wk1(i)=vlsc2(w,v(1,i),ntot2)       ! h    = (w,v )
c           enddo                                 !  i,j       i
c                                                 !
c           call gop(wk1,wk2,'+  ',j)             ! sum over P procs
c
c           do i=1,j
c              call add2s2(w,v(1,i),-wk1(i),ntot2)! w = w - h    v
c              h(i,j) = h(i,j) + wk1(i)           !          i,j  i
c           enddo

            !apply Givens rotations to new column
            do i=1,j-1
               temp = h(i,j)
               h(i  ,j)=  c(i)*temp + s(i)*h(i+1,j)
               h(i+1,j)= -s(i)*temp + c(i)*h(i+1,j)
            enddo
                                                  !            ______
            alpha = sqrt(glsc2(w,w,ntot2))        ! alpha =  \/ (w,w)
            rnorm = 0.
            if(alpha.eq.0.) goto 900  !converged
            l = sqrt(h(j,j)*h(j,j)+alpha*alpha)
            temp = 1./l
            c(j) = h(j,j) * temp
            s(j) = alpha  * temp
            h(j,j) = l
            gamma(j+1) = -s(j) * gamma(j)
            gamma(j)   =  c(j) * gamma(j)

c            call outmat(h,m,j,' h    ',j)

            rnorm = abs(gamma(j+1))*norm_fac
            ratio = rnorm/div0
            if (ifprint.and.nid.eq.0)
     $         write (6,66) iter,tolpss,rnorm,div0,ratio,istep
   66       format(i5,1p4e12.5,i8,' Divergence')

#ifndef TST_WSCAL
            if (rnorm .lt. tolpss) goto 900  !converged
#else
            if (iter.gt.param(151)-1) goto 900
#endif
            if (j.eq.m) goto 1000 !not converged, restart

            temp = 1./alpha
            call cmult2(v(1,j+1),w,temp,ntot2)   ! v    = w / alpha
                                                 !  j+1
         enddo
  900    iconv = 1
 1000    continue
         !back substitution
         !     -1
         !c = H   gamma
         do k=j,1,-1
            temp = gamma(k)
            do i=j,k+1,-1
               temp = temp - h(k,i)*c(i)
            enddo
            c(k) = temp/h(k,k)
         enddo
         !sum up Arnoldi vectors
         do i=1,j
            call add2s2(x,z(1,i),c(i),ntot2)     ! x = x + c  z
                                                 !          i  i
         enddo
c        if(iconv.eq.1) call dbg_write(x,nx2,ny2,nz2,nelv,'esol',3)
      enddo
 9000 continue
c
      divex = rnorm
c     iter = iter - 1
c
c     DIAGNOSTICS
c      call copy   (w,x,ntot2)
       call ortho  (w) ! Orthogonalize wrt null space, if present
c      call copy(r,res,ntot2) !r = res
c      call cdabdtp(r,w,h1,h2,h2inv,intype)  ! r = A w
c      do i=1,ntot2
c         r(i) = res(i) - r(i)               ! r = res - r
c      enddo
c      call uzawa_gmres_temp(r,bm2inv,ntot2)
c                                               !            ______
c      gamma(1) = sqrt(glsc2(r,r,ntot2)/volvm2) ! gamma  = \/ (r,r)
c                                               !      1
c      print *, 'GMRES end resid:',gamma(1)
c     END DIAGNOSTICS
      call copy(res,x,ntot2)

      call ortho (res)  ! Orthogonalize wrt null space, if present

      etime1 = dnekclock()-etime1
      if (nid.eq.0) write(6,9999) istep,iter,divex,tolpss,div0,etime_p,
     &                            etime1
c     call flush_hack
 9999 format(i10,' U-PRES gmres:',I7,1p5e12.4)

      return
      end

c-----------------------------------------------------------------------

      subroutine uzawa_gmres_split0(l,u,b,binv,n)
      integer n
      real l(n),u(n),b(n),binv(n)
      integer i
      do i=1,n
         l(i)=sqrt(binv(i))
         u(i)=sqrt(b(i))
         if(abs(u(i)*l(i)-1.0).gt.1e-13) print *, i, u(i)*l(i)
      enddo
      return
      end

c-----------------------------------------------------------------------
      subroutine uzawa_gmres_split(l,u,b,binv,n)
      integer n
      real l(n),u(n),b(n),binv(n)
      integer i
      do i=1,n
c        l(i)=sqrt(binv(i))
c        u(i)=sqrt(b(i))

c        u(i)=sqrt(b(i))
c        l(i)=1./u(i)

c        l(i)=sqrt(binv(i))
         l(i)=1.
         u(i)=1./l(i)

c        if(abs(u(i)*l(i)-1.0).gt.1e-13)write(6,*) i,u(i)*l(i),' gmr_sp'
      enddo
      return
      end

c-----------------------------------------------------------------------
      subroutine uzawa_gmres_temp(a,b,n)
      integer n
      real a(n),b(n)
      integer i
      do i=1,n
         a(i)=sqrt(b(i))*a(i)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine ax(w,x,h1,h2,n)
      include 'SIZE'
      include 'TOTAL'

c
c     w = A*x for pressure iteration
c

      integer n
      real w(n),x(n),h1(n),h2(n)

      imsh = 1
      isd  = 1
      call axhelm (w,x,h1,h2,imsh,isd)
      call dssum  (w,nx1,ny1,nz1)
      call col2   (w,pmask,n)

      return
      end
c-----------------------------------------------------------------------
      subroutine hmh_gmres(res,h1,h2,wt,iter)

c     Solve the Helmholtz equation by right-preconditioned
c     GMRES iteration.

      include 'SIZE'
      include 'TOTAL'
      include 'FDMH1'
      include 'GMRES'
      common  /ctolpr/ divex
      common  /cprint/ ifprint
      logical          ifprint
      real             res  (lx1*ly1*lz1*lelv)
      real             h1   (lx1,ly1,lz1,lelv)
      real             h2   (lx1,ly1,lz1,lelv)
      real             wt   (lx1,ly1,lz1,lelv)

      common /scrcg/ d(lx1*ly1*lz1*lelv),wk(lx1*ly1*lz1*lelv)

      common /cgmres1/ y(lgmres)
      common /ctmp0/   wk1(lgmres),wk2(lgmres)
      real alpha, l, temp
      integer outer

      logical iflag,if_hyb
      save    iflag,if_hyb
c     data    iflag,if_hyb  /.false. , .true. /
      data    iflag,if_hyb  /.false. , .false. /
      real    norm_fac
      save    norm_fac

      real*8 etime1,dnekclock

      n = nx1*ny1*nz1*nelv

      etime1 = dnekclock()
      etime_p = 0.
      divex = 0.
      iter  = 0
      m     = lgmres

      if(.not.iflag) then
         iflag=.true.
         call uzawa_gmres_split(ml,mu,bm1,binvm1,nx1*ny1*nz1*nelv)
         norm_fac = 1./sqrt(volvm1)
      endif

      if (param(100).ne.2) call set_fdm_prec_h1b(d,h1,h2,nelv)

      call chktcg1(tolps,res,h1,h2,pmask,vmult,1,1)
      if (param(21).gt.0.and.tolps.gt.abs(param(21)))
     $   tolps = abs(param(21))
      if (istep.eq.0) tolps = 1.e-4
      tolpss = tolps
c
      iconv = 0
      call rzero(x,n)

      outer = 0
      do while (iconv.eq.0.and.iter.lt.500)
         outer = outer+1

         if(iter.eq.0) then               !      -1
            call col3(r,ml,res,n)         ! r = L  res
c           call copy(r,res,n)
         else
            !update residual
            call copy  (r,res,n)                  ! r = res
            call ax    (w,x,h1,h2,n)              ! w = A x
            call add2s2(r,w,-1.,n)                ! r = r - w
                                                  !      -1
            call col2(r,ml,n)                     ! r = L   r
         endif
                                                  !            ______
         gamma(1) = sqrt(glsc3(r,r,wt,n))         ! gamma  = \/ (r,r)
                                                  !      1
         if(iter.eq.0) then
            div0 = gamma(1)*norm_fac
            if (param(21).lt.0) tolpss=abs(param(21))*div0
         endif

         !check for lucky convergence
         rnorm = 0.
         if(gamma(1) .eq. 0.) goto 9000
         temp = 1./gamma(1)
         call cmult2(v(1,1),r,temp,n)             ! v  = r / gamma
                                                  !  1            1
         do j=1,m
            iter = iter+1
                                                  !       -1
            call col3(w,mu,v(1,j),n)              ! w  = U   v
                                                  !           j

c . . . . . Overlapping Schwarz + coarse-grid . . . . . . .

            etime2 = dnekclock()

c           if (outer.gt.2) if_hyb = .true.       ! Slow outer convergence
            if (ifmgrid) then
               call h1mg_solve(z(1,j),w,if_hyb)   ! z  = M   w
            else                                  !  j
               kfldfdm = ndim+1
               if (param(100).eq.2) then
                   call h1_overlap_2 (z(1,j),w,pmask)
               else
                   call fdm_h1
     $               (z(1,j),w,d,pmask,vmult,nelv,ktype(1,1,kfldfdm),wk)
               endif
               call crs_solve_h1 (wk,w)           ! z  = M   w
               call add2         (z(1,j),wk,n)    !  j
            endif

            call ortho        (z(1,j)) ! Orthogonalize wrt null space, if present
            etime_p = etime_p + dnekclock()-etime2
c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

            call ax  (w,z(1,j),h1,h2,n)           ! w = A z
                                                  !        j

                                                  !      -1
            call col2(w,ml,n)                     ! w = L   w

c           !modified Gram-Schmidt

c           do i=1,j
c              h(i,j)=glsc3(w,v(1,i),wt,n)        ! h    = (w,v )
c                                                 !  i,j       i

c              call add2s2(w,v(1,i),-h(i,j),n)    ! w = w - h    v
c           enddo                                 !          i,j  i

c           2-PASS GS, 1st pass:

            do i=1,j
               h(i,j)=vlsc3(w,v(1,i),wt,n)        ! h    = (w,v )
            enddo                                 !  i,j       i

            call gop(h(1,j),wk1,'+  ',j)          ! sum over P procs

            do i=1,j
               call add2s2(w,v(1,i),-h(i,j),n)    ! w = w - h    v
            enddo                                 !          i,j  i

c           2-PASS GS, 2nd pass:
c
c           do i=1,j
c              wk1(i)=vlsc3(w,v(1,i),wt,n)        ! h    = (w,v )
c           enddo                                 !  i,j       i
c                                                 !
c           call gop(wk1,wk2,'+  ',j)             ! sum over P procs
c
c           do i=1,j
c              call add2s2(w,v(1,i),-wk1(i),n)    ! w = w - h    v
c              h(i,j) = h(i,j) + wk1(i)           !          i,j  i
c           enddo

            !apply Givens rotations to new column
            do i=1,j-1
               temp = h(i,j)
               h(i  ,j)=  c(i)*temp + s(i)*h(i+1,j)
               h(i+1,j)= -s(i)*temp + c(i)*h(i+1,j)
            enddo
                                                 !            ______
            alpha = sqrt(glsc3(w,w,wt,n))        ! alpha =  \/ (w,w)
            rnorm = 0.
            if(alpha.eq.0.) goto 900  !converged
            l = sqrt(h(j,j)*h(j,j)+alpha*alpha)
            temp = 1./l
            c(j) = h(j,j) * temp
            s(j) = alpha  * temp
            h(j,j) = l
            gamma(j+1) = -s(j) * gamma(j)
            gamma(j)   =  c(j) * gamma(j)

            rnorm = abs(gamma(j+1))*norm_fac
            ratio = rnorm/div0
            if (ifprint.and.nid.eq.0)
     $         write (6,66) iter,tolpss,rnorm,div0,ratio,istep
   66       format(i5,1p4e12.5,i8,' Divergence')

#ifndef TST_WSCAL
            if (rnorm .lt. tolpss) goto 900  !converged
#else
            if (iter.gt.param(151)-1) goto 900
#endif
            if (j.eq.m) goto 1000 !not converged, restart

            temp = 1./alpha
            call cmult2(v(1,j+1),w,temp,n)   ! v    = w / alpha
                                             !  j+1
         enddo
  900    iconv = 1
 1000    continue
         !back substitution
         !     -1
         !c = H   gamma
         do k=j,1,-1
            temp = gamma(k)
            do i=j,k+1,-1
               temp = temp - h(k,i)*c(i)
            enddo
            c(k) = temp/h(k,k)
         enddo
         !sum up Arnoldi vectors
         do i=1,j
            call add2s2(x,z(1,i),c(i),n)     ! x = x + c  z
         enddo                               !          i  i
c        if(iconv.eq.1) call dbg_write(x,nx1,ny1,nz1,nelv,'esol',3)
      enddo
 9000 continue

      divex = rnorm
      call copy(res,x,n)

      call ortho   (res) ! Orthogonalize wrt null space, if present

      etime1 = dnekclock()-etime1
      if (nid.eq.0) write(6,9999) istep,iter,divex,tolpss,div0,etime_p,
     &                            etime1,if_hyb
c     call flush_hack
 9999 format(i9,' PRES gmres:',i5,1p5e12.4,1x,l4)

      if (outer.le.2) if_hyb = .false.

      return
      end
c-----------------------------------------------------------------------
      subroutine set_overlap2
c
c     Sets up the gather scatter and the SEM operators
c
      include 'SIZE'
      include 'TOTAL'

      common /c_is1/ glo_num(lxs*lys*lzs*lelv)
      integer*8 glo_num
      common /ivrtx/ vertex ((2**ldim)*lelt)
      common /handle/ gsh_dd
      integer vertex,gsh_dd

      mz = ndim-2
      nx = nx1+2
      ny = ny1+2
      nz = nz1+2*mz
      call setupds_no_crn(gsh_dd,nx,ny,nz,nelv,nelgv,vertex,glo_num)
      call swap_lengths ! Set up Matrices for FDM
      call gen_fast_g

      return
      end
c-----------------------------------------------------------------------
      subroutine h1_overlap_2(u,v,mask)
c
c     Local overlapping Schwarz solves with overlap of 2
c
      include 'SIZE'
      include 'TOTAL'

      common /cwork1/ v1(lxs,lys,lzs,lelt)
      common /handle/ gsh_dd
      integer gsh_dd

      real u(lx1,lx1,lz1,1),v(1),mask(1)
      integer e

      n = nx1*ny1*nz1*nelfld(ifield)

      call dd_swap_vals(v1,v,gsh_dd)

      iz1 = 0
      if (if3d) iz1=1
      do ie=1,nelfld(ifield)
         do iz=1,nz1
         do iy=1,ny1
         do ix=1,nx1
            u(ix,iy,iz,ie) = v1(ix+1,iy+1,iz+iz1,ie)
         enddo
         enddo
         enddo
      enddo

      call dssum (u,nx1,ny1,nz1)
      call col2  (u,mask,n)

      return
      end
c-----------------------------------------------------------------------
      subroutine dd_swap_vals(v1,v0,gsh_dd)

      include 'SIZE'
      include 'TOTAL'

      common /work1/ w1(lxs,lys,lzs)           ! work arrarys for locals
     $              ,w2(lxs,lys,lzs)
      integer gsh_dd

      real v1(lxs,lys,lzs,lelt)
      real v0(lx1,ly1,lz1,lelt)

      integer e

      mz = ndim-2

      nx = nx1+2
      ny = ny1+2
      nz = nz1+2*mz

      n  = nx1*ny1*nz1*nelv
      m  = (nx1+2)*(ny1+2)*(nz1+2*mz)*nelv

      do e=1,nelv
         call rzero_g        (v1,e,nx,ny,nz)
         call fill_interior_g(v1,v0,e,nx1,nz1,mz,nelv)    ! v0      --> v1(int)
         call dface_ext_g    (v1,2,e,nx,nz)               ! v1(int) --> v1(face)
      enddo
c
c                 ~ ~T
c     This is the Q Q  part
c
      call gs_op(gsh_dd,v1,1,1,0)  ! 1 ==> +         ! swap v1 & add vals

      do e =1,nelv
         call dface_add1si_g  (v1,-1.,2,e,nx,nz)
         call fastdm1_g       (v1(1,1,1,e),e,w1,w2)
         call s_face_to_int2_g(v1,-1.,2,e,nx,nz)
      enddo
c
c     Exchange/add elemental solutions
c
      call gs_op              (gsh_dd,v1,1,1,0)
      do e =1,nelv
         call s_face_to_int2_g(v1,1.,2,e,nx,nz)
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine gen_fast_g
c
c     Generate fast diagonalization matrices for each element
c
      include 'SIZE'
      include 'INPUT'
      include 'PARALLEL'
      include 'SOLN'
      include 'WZ'

      parameter (lxss=lxs*lxs)
      common /fastg/  sr(lxss,2,lelv),ss(lxss,2,lelv),st(lxss,2,lelv)
     $             ,  df(lxs*lys*lzs,lelv)

      common /ctmpf/  lr(2*lx1+4),ls(2*lx1+4),lt(2*lx1+4)
     $              , llr(lelt),lls(lelt),llt(lelt)
     $              , lmr(lelt),lms(lelt),lmt(lelt)
     $              , lrr(lelt),lrs(lelt),lrt(lelt)
      real lr ,ls ,lt
      real llr,lls,llt
      real lmr,lms,lmt
      real lrr,lrs,lrt

      integer lbr,rbr,lbs,rbs,lbt,rbt

      call load_semhat_weighted   !   Fills the SEMHAT arrays

      ierr = 0
      do ie=1,nelv

         call get_fast_bc(lbr,rbr,lbs,rbs,lbt,rbt,ie,3,ierr)
c
c        Set up matrices for each element.
c
         call set_up_fast_1D_sem_g( sr(1,1,ie),lr,nr ,lbr,rbr
     $                      ,llr(ie),lmr(ie),lrr(ie),ie)
         call set_up_fast_1D_sem_g( ss(1,1,ie),ls,ns ,lbs,rbs
     $                      ,lls(ie),lms(ie),lrs(ie),ie)
         if (if3d) then
            call set_up_fast_1D_sem_g( st(1,1,ie),lt,nt ,lbt,rbt
     $                      ,llt(ie),lmt(ie),lrt(ie),ie)
         endif
c
c        Set up diagonal inverse
c
         if (if3d) then
            eps = 1.e-5 * (vlmax(lr(2),nr-2)
     $                  +  vlmax(ls(2),ns-2) + vlmax(lt(2),nt-2))
            l   = 1
            do k=1,nt
            do j=1,ns
            do i=1,nr
               diag = lr(i) + ls(j) + lt(k)
               if (diag.gt.eps) then
                  df(l,ie) = 1.0/diag
               else
c                 write(6,3) ie,'Reset Eig in gen fast:',i,j,k,l
c    $                         ,eps,diag,lr(i),ls(j),lt(k)
c   3             format(i6,1x,a21,4i5,1p5e12.4)
                  df(l,ie) = 0.0
               endif
               l = l+1
            enddo
            enddo
            enddo
         else
            eps = 1.e-5*(vlmax(lr(2),nr-2) + vlmax(ls(2),ns-2))
            l   = 1
            do j=1,ns
            do i=1,nr
               diag = lr(i) + ls(j)

               if (diag.gt.eps) then
                  df(l,ie) = 1.0/diag

               else
c                 write(6,2) ie,'Reset Eig in gen fast:',i,j,l
c    $                         ,eps,diag,lr(i),ls(j)
c   2             format(i6,1x,a21,3i5,1p4e12.4)
                  df(l,ie) = 0.0
               endif
               l = l+1
            enddo
            enddo
         endif
c
c        Next element ....
c
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine set_up_fast_1D_sem_g(s,lam,n,lbc,rbc,ll,lm,lr,ie)
      include 'SIZE'
      include 'SEMHAT'

      parameter (lr3=2*lxs*lxs)
      common /fast1dsem/ g(lr3),w(lr3)

      real g,w
      real s(1),lam(1),ll,lm,lr
      integer lbc,rbc

      integer bb0,bb1,eb0,eb1,n,n1
      logical l,r

      n=nx1-1
      !bcs on E are from normal vel component
      if(lbc.eq.2 .or. lbc.eq.3) then !wall,sym  - Neumann
         eb0=0
         bb0=0
      else !outflow,element                      - Dirichlet
         eb0=1
         bb0=1
      endif
      if(rbc.eq.2 .or. rbc.eq.3) then !wall,sym  - Neumann
         eb1=n
         bb1=n
      else !outflow,element                      - Dirichlet
         eb1=n-1
         bb1=n-1
      endif
      l = (lbc.eq.0)
      r = (rbc.eq.0)

c     calculate A tilde operator
      call set_up_fast_1D_sem_op_a(s,eb0,eb1,l,r,ll,lm,lr,ah)
c     calculate B tilde operator
      call set_up_fast_1D_sem_op_b(g,bb0,bb1,l,r,ll,lm,lr,bh)

      n=n+3
c     call outmat   (s,n,n,'  A   ',ie)
c     call outmat   (g,n,n,'  B   ',ie)
      call generalev(s,g,lam,n,w)
      if(.not.l) call row_zero(s,n,n,1)
      if(.not.r) call row_zero(s,n,n,n)
      call transpose(s(n*n+1),n,s,n) ! compute the transpose of s
c     call outmat   (s,n,n,'  S   ',ie)
c     call outmat   (s(n*n+1),n,n,'  St  ',1)
c     call exitt

      return
      end
c-----------------------------------------------------------------------
      subroutine set_up_fast_1D_sem_op_a(g,b0,b1,l
     $                                   ,r,ll,lm,lr,ah)
c            -1 T
c     G = J B  J
c
c     gives the inexact restriction of this matrix to
c     an element plus two node on either side
c
c     g - the output matrix
c     b0, b1 - the range for Bhat indices for the element
c              (enforces boundary conditions)
c     l, r - whether there is a left or right neighbor
c     ll,lm,lr - lengths of left, middle, and right elements
c     ah - hat matrix for A or B
c
c     result is inexact because:
c        neighbor's boundary condition at far end unknown
c        length of neighbor's neighbor unknown
c        (these contribs should be small for large N and
c         elements of nearly equal size)
c
      include 'SIZE'
      real g(0:lx1+1,0:lx1+1)
      real ah(0:lx1-1,0:lx1-1)
      real ll,lm,lr
      integer b0,b1
      logical l,r

      real bl,bm,br
      integer n

      n =nx1-1

c
c     compute the weight of A hat
c
      if (l) bl = 2. /ll
             bm = 2. /lm
      if (r) br = 2. /lr

      call rzero(g,(n+3)*(n+3))
      do j=1,n+1
         do i=1,n+1
            g(i,j) = ah(i-1,j-1)*bm
         enddo
      enddo

      if (l) then
         g(0,0) = g(0,0) + bl*ah(n-1,n-1)
         g(0,1) = g(0,1) + bl*ah(n-1,n  )
         g(1,0) = g(1,0) + bl*ah(n  ,n-1)
         g(1,1) = g(1,1) + bl*ah(n  ,n  )
      elseif (b0.eq.0) then          !Neumann BC
         g(0,0) = 1.
      else                           !Dirichlet BC
         g(0,0)     = 1.
         g(1,1)     = 1.
         do i=2,n+1
            g(i,1)  = 0.
            g(1,i)  = 0.
         enddo
      endif

      if (r) then
         g(n+1,n+1) = g(n+1,n+1) + br*ah(0,0)
         g(n+1,n+2) = g(n+1,n+2) + br*ah(0,1)
         g(n+2,n+1) = g(n+2,n+1) + br*ah(0,1)
         g(n+2,n+2) = g(n+2,n+2) + br*ah(1,1)
      elseif (b1.eq.n) then          !Neumann BC
         g(n+2,n+2)=1.
      else                           !Dirichlet BC
         g(n+2,n+2)   = 1.
         g(n+1,n+1)   = 1.
         do i=1,n
            g(i,n+1)  = 0.
            g(n+1,i)  = 0.
         enddo
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine set_up_fast_1D_sem_op_b(g,b0,b1,l
     $                                   ,r,ll,lm,lr,bh)
c            -1 T
c     G = J B  J
c
c     gives the inexact restriction of this matrix to
c     an element plus two node on either side
c
c     g - the output matrix
c     b0, b1 - the range for Bhat indices for the element
c              (enforces boundary conditions)
c     l, r - whether there is a left or right neighbor
c     ll,lm,lr - lengths of left, middle, and right elements
c     bh - hat matrix for  B
c
c     result is inexact because:
c        neighbor's boundary condition at far end unknown
c        length of neighbor's neighbor unknown
c        (these contribs should be small for large N and
c         elements of nearly equal size)
c
      include 'SIZE'
      real g(0:lx1+1,0:lx1+1)
      real bh(0:lx1-1)
      real ll,lm,lr
      integer b0,b1
      logical l,r

      real bl,bm,br
      integer n

      n =nx1-1
c
c     compute the weight of B hat
c
      if (l) bl = ll / 2.
             bm = lm / 2.
      if (r) br = lr / 2.

      call rzero(g,(n+3)*(n+3))
      do i=1,n+1
            g(i,i) = bh(i-1)*bm
      enddo

      if (l) then
         g(0,0) = g(0,0) + bl*bh(n-1)
         g(1,1) = g(1,1) + bl*bh(n  )
      elseif (b0.eq.0) then          !Neumann BC
         g(0,0) = 1.
      else                           !Dirichlet BC
         g(0,0)     = 1.
         g(1,1)     = 1.
         do i=2,n+1
            g(i,1)  = 0.
            g(1,i)  = 0.
         enddo
      endif

      if (r) then
         g(n+1,n+1) = g(n+1,n+1) + br*bh(0)
         g(n+2,n+2) = g(n+2,n+2) + br*bh(1)
      elseif (b1.eq.n) then          !Neumann BC
         g(n+2,n+2)=1.
      else                           !Dirichlet BC
         g(n+2,n+2)   = 1.
         g(n+1,n+1)   = 1.
         do i=1,n
            g(i,n+1)  = 0.
            g(n+1,i)  = 0.
         enddo
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine fill_interior_g(v1,v,e,nx,nz,iz1,nel)

      real v1(nx+2,nx+2,nz+2*iz1,nel) ! iz1=ndim-2
      real v (nx  ,nx  ,nz      ,nel)
      integer e

      ny = nx

      do iz=1,nz
      do iy=1,ny
      do ix=1,nx
         v1(ix+1,iy+1,iz+iz1,e) = v(ix,iy,iz,e)
      enddo
      enddo
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine dface_ext_g(x,t,e,nx,nz)
c     Extend interior to face of element

      include 'SIZE'
      include 'INPUT'
      real x(nx,nx,nz,1)
      integer e,t

      ny = nx

      if (if3d) then
        do iz=2,nz-1
        do ix=2,nx-1
            x(ix,1 ,iz,e) = x(ix, 1+t,iz,e)
            x(ix,ny,iz,e) = x(ix,ny-t,iz,e)
        enddo
        enddo

        do iz=2,nz-1
        do iy=2,ny-1
            x(1 ,iy,iz,e) = x( 1+t,iy,iz,e)
            x(nx,iy,iz,e) = x(nx-t,iy,iz,e)
        enddo
        enddo

        do iy=2,ny-1
        do ix=2,nx-1
            x(ix,iy,1 ,e) = x(ix,iy, 1+t,e)
            x(ix,iy,nz,e) = x(ix,iy,nz-t,e)
        enddo
        enddo
      else
         do ix=2,nx-1
            x(ix,1 ,1,e) = x(ix, 1+t,1,e)
            x(ix,ny,1,e) = x(ix,ny-t,1,e)
         enddo
         do iy=2,ny-1
            x(1 ,iy,1,e) = x( 1+t,iy,1,e)
            x(nx,iy,1,e) = x(nx-t,iy,1,e)
         enddo
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine dface_add1si_g(x,c,t,e,nx,nz)
c     Scale interior and add to face of element

      include 'SIZE'
      include 'INPUT'
      real x(nx,nx,nz,1)

      integer e,t

      ny = nx

      if (if3d) then

         do iz=2,nz-1
         do ix=2,nx-1
            x(ix,1 ,iz,e) = x(ix,1 ,iz,e) + c*x(ix, 1+t,iz,e)
            x(ix,ny,iz,e) = x(ix,ny,iz,e) + c*x(ix,ny-t,iz,e)
         enddo
         enddo

         do iz=2,nz-1
         do iy=2,ny-1
            x(1 ,iy,iz,e) = x(1 ,iy,iz,e) + c*x( 1+t,iy,iz,e)
            x(nx,iy,iz,e) = x(nx,iy,iz,e) + c*x(nx-t,iy,iz,e)
         enddo
         enddo

         do iy=2,ny-1
         do ix=2,nx-1
            x(ix,iy,1 ,e) = x(ix,iy,1 ,e) + c*x(ix,iy, 1+t,e)
            x(ix,iy,nz,e) = x(ix,iy,nz,e) + c*x(ix,iy,nz-t,e)
         enddo
         enddo

      else  ! 2D

         do ix=2,nx-1
            x(ix,1 ,1,e) = x(ix,1 ,1,e) + c*x(ix, 1+t,1,e)
            x(ix,ny,1,e) = x(ix,ny,1,e) + c*x(ix,ny-t,1,e)
         enddo
         do iy=2,ny-1
            x(1  ,iy,1,e) = x(1 ,iy,1,e) + c*x( 1+t,iy,1,e)
            x(nx ,iy,1,e) = x(nx,iy,1,e) + c*x(nx-t,iy,1,e)
         enddo

      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine fastdm1_g(R,ie,w1,w2)
c
c     Fast diagonalization solver for FEM on mesh 1
c
      include 'SIZE'

      parameter (lxss=lxs*lxs)
      common /fastg/  sr(lxss,2,lelv),ss(lxss,2,lelv),st(lxss,2,lelv)
     $             ,  df(lxs*lys*lzs,lelv)

      parameter (lxyz = lxs*lys*lzs)

      real r(1),w1(1),w2(1)

      nx = nx1+2
c
c      T
c     S  r
      call tensr3 (w1,nx,r ,nx,sr(1,2,ie),ss(1,1,ie),st(1,1,ie),w2)
c
c
c      -1 T
c     D  S  r
c
      call col2   (w1,df(1,ie),lxyz)
c
c
c        -1 T
c     S D  S  r
c
      call tensr3 (r ,nx,w1,nx,sr(1,1,ie),ss(1,2,ie),st(1,2,ie),w2)

      return
      end
c-----------------------------------------------------------------------
      subroutine s_face_to_int2_g(x,c,t,e,nx,nz)
c
c     Scale face and add to interior of element
c
      include 'SIZE'
      include 'INPUT'
      real x(nx,nx,nz,1)
      integer t,e

      ny=nx

      if (if3d) then

         do iz=2,nz-1
         do ix=2,nx-1
            x(ix, 1+t,iz,e) = c*x(ix,1 ,iz,e) + x(ix, 1+t,iz,e)
            x(ix,ny-t,iz,e) = c*x(ix,ny,iz,e) + x(ix,ny-t,iz,e)
         enddo
         enddo

         do iz=2,nz-1
         do iy=2,ny-1
            x( 1+t,iy,iz,e) = c*x(1 ,iy,iz,e) + x( 1+t,iy,iz,e)
            x(nx-t,iy,iz,e) = c*x(nx,iy,iz,e) + x(nx-t,iy,iz,e)
         enddo
         enddo

         do iy=2,ny-1
         do ix=2,nx-1
            x(ix,iy, 1+t,e) = c*x(ix,iy,1 ,e) + x(ix,iy, 1+t,e)
            x(ix,iy,nz-t,e) = c*x(ix,iy,nz,e) + x(ix,iy,nz-t,e)
         enddo
         enddo

      else
c     2D
         do ix=2,nx-1
            x(ix, 1+t,1,e) = c*x(ix,1 ,1,e) + x(ix, 1+t,1,e)
            x(ix,ny-t,1,e) = c*x(ix,ny,1,e) + x(ix,ny-t,1,e)
         enddo
         do iy=2,ny-1
            x( 1+t,iy,1,e) = c*x(1 ,iy,1,e) + x( 1+t,iy,1,e)
            x(nx-t,iy,1,e) = c*x(nx,iy,1,e) + x(nx-t,iy,1,e)
         enddo
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine outfldr_g(x,txt10,nx,nz,ichk)
      INCLUDE 'SIZE'
      INCLUDE 'TSTEP'
      real x(nx,nx,nz,lelt)
      character*10 txt10

      integer idum,e
      save idum
      data idum /3/

      if (idum.lt.0) return

      ny = nx

      mtot = nx*ny*nz*nelv
      if (nx.gt.8.or.nelv.gt.16) return
      xmin = glmin(x,mtot)
      xmax = glmax(x,mtot)

      nell = nelt
      rnel = nell
      snel = sqrt(rnel)+.1
      ne   = snel
      ne1  = nell-ne+1
      k = 1
      do ie=1,1
         ne = 0
         write(6,116) txt10,k,ie,xmin,xmax,istep,time,nx
         do l=12,0,-4
            write(6,117)
            do j=ny,1,-1
              if (nx.eq.2) write(6,102) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.3) write(6,103) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.4) write(6,104) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.5) write(6,105) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.6) write(6,106) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.7) write(6,107) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.8) write(6,118) ((x(i,j,k,e+l),i=1,nx),e=1,4)
            enddo
         enddo
      enddo

  102 FORMAT(4(2f9.5,2x))
  103 FORMAT(4(3f9.5,2x))
  104 FORMAT(4(4f7.3,2x))
  105 FORMAT(5f9.5,10x,5f9.5)
  106 FORMAT(6f7.1,5x,6f7.1,5x,6f7.1,5x,6f7.1)
  107 FORMAT(7f8.4,5x,7f8.4)
  108 FORMAT(8f8.4,4x,8f8.4)
  118 FORMAT(8f12.9)

  116 FORMAT(  /,5X,'     ^              ',/,
     $    5X,'   Y |              ',/,
     $    5X,'     |              ',A10,/,
     $    5X,'     +---->         ','Plane = ',I2,'/',I2,2x,2e12.4,/,
     $    5X,'       X            ','Step  =',I9,f15.5,i2)
  117 FORMAT(' ')

      if (ichk.eq.1.and.idum.gt.0) call checkit(idum)
      return
      end
c-----------------------------------------------------------------------
      subroutine outfldi_g(x,txt10,nx,nz,ichk)
      INCLUDE 'SIZE'
      INCLUDE 'TSTEP'
      integer x(nx,nx,nz,lelt)
      character*10 txt10

      integer idum,e,xmin,xmax
      save idum
      data idum /3/

      if (idum.lt.0) return

      ny = nx

      mtot = nx*ny*nz*nelv
      if (nx.gt.8.or.nelv.gt.16) return
      xmin = iglmin(x,mtot)
      xmax = iglmax(x,mtot)

      nell = nelt
      rnel = nell
      snel = sqrt(rnel)+.1
      ne   = snel
      ne1  = nell-ne+1
      k = 1
      do ie=1,1
         ne = 0
         write(6,116) txt10,k,ie,xmin,xmax,istep,time,nx
         do l=12,0,-4
            write(6,117)
            do j=ny,1,-1
              if (nx.eq.2) write(6,102) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.3) write(6,103) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.4) write(6,104) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.5) write(6,105) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.6) write(6,106) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.7) write(6,107) ((x(i,j,k,e+l),i=1,nx),e=1,4)
              if (nx.eq.8) write(6,118) ((x(i,j,k,e+l),i=1,nx),e=1,4)
            enddo
         enddo
      enddo

  102 FORMAT(4(2i9,2x))
  103 FORMAT(4(3i9,2x))
  104 FORMAT(4(4i7,2x))
  105 FORMAT(5i9,10x,5i9)
  106 FORMAT(6i7,5x,6i7,5x,6i7,5x,6i7)
  107 FORMAT(7i8,5x,7i8)
  108 FORMAT(8i8,4x,8i8)
  118 FORMAT(8i12)

  116 FORMAT(  /,5X,'     ^              ',/,
     $    5X,'   Y |              ',/,
     $    5X,'     |              ',A10,/,
     $    5X,'     +---->         ','Plane = ',I2,'/',I2,2x,2i12,/,
     $    5X,'       X            ','Step  =',I9,f15.5,i2)
  117 FORMAT(' ')

      if (ichk.eq.1.and.idum.gt.0) call checkit(idum)
      return
      end
c-----------------------------------------------------------------------
      subroutine setupds_no_crn(gs_h,nx,ny,nz,nel,melg,vertex,glo_num)
      include 'SIZE'
      include 'INPUT'
      include 'PARALLEL'
      include 'NONCON'
      integer   gs_h,vertex(1),e
      integer*8 ngv,glo_num(nx,ny,nz,nel)

      common /nekmpi/ mid,mp,nekcomm,nekgroup,nekreal

c     set up the global numbering
      call set_vert(glo_num,ngv,nx,nel,vertex,.false.)

c     zero out corners
      mz1 = max(1,nz-1)
      do e=1,nel
      do k=1,nz,mz1
      do j=1,ny,ny-1
      do i=1,nx,nx-1
         glo_num(i,j,k,e) = 0
      enddo
      enddo
      enddo
      enddo

      ntot = nx*ny*nz*nel

      t0 = dnekclock()
      call gs_setup(gs_h,glo_num,ntot,nekcomm,mp) ! initialize gs code
      t1 = dnekclock()

      et = t1-t0

c     call gs_chkr(glo_num)

      if (nid.eq.0) then
         write(6,1) et,nx,nel,ntot,ngv,gs_h
    1    format('   gs_init time',1pe11.4,' seconds ',i3,4i10)
      endif
c
      return
      end
c-----------------------------------------------------------------------
      subroutine rzero_g(a,e,nx,ny,nz)

      real a(nx,ny,nz,1)
      integer e

      do  i=1,nx
      do  j=1,ny
      do  k=1,nz
          a(i,j,k,e) = 0.0
      enddo
      enddo
      enddo

      return
      END
c-----------------------------------------------------------------------


!*******************************************************************
!                                                                  *
      INTEGER FUNCTION IZAS1(IB,QB,IK,QK)
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vilnius,  Lithuania                             March    1995  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: TENTH, TWO
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER,      INTENT(IN) :: IB, IK
      REAL(DOUBLE), INTENT(IN) :: QB, QK
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IQB, IQK
!-----------------------------------------------
      IZAS1=0
      IQB=TWO*DABS(QB)+TENTH
      IF(IQB > IB)RETURN
      IF(MOD(IB+IQB,2) /= 0)RETURN
      IQK=TWO*DABS(QK)+TENTH
      IF(IQK > IK)RETURN
      IF(MOD(IK+IQK,2) /= 0)RETURN
      IZAS1=1
      RETURN
      END  FUNCTION IZAS1


C
C     This file is a part of HAXX
C
C     Copyright (c) 2017 David Williams-Young
C     All rights reserved.
C
C     See LICENSE.txt
C
      Subroutine HSCALC(SIDE, N, ALPHA, X, INCX)
C
      LOGICAL LSAME
      EXTERNAL LSAME
C
      LOGICAL    MRIGHT
      CHARACTER  SIDE
      INTEGER*4  N, INCX, I, IX
      COMPLEX*16 ALPHA, X(2,*)
C
      COMPLEX*16 HTMPS, HTMPJ
C
      IF ( N.LE.0 ) RETURN
      IF ( ABS(ALPHA).EQ.0.0D0  ) RETURN
C
      MRIGHT = LSAME('R',SIDE)
C
      IF ( INCX.EQ.1  ) THEN
        IF ( .NOT. MRIGHT ) THEN
          DO 10 I = 1,N
C           Hamilton Product
            X(1,I) = ALPHA * X(1,I)
            X(2,I) = ALPHA * X(2,I)
  10      CONTINUE
        ELSE
          DO 20 I = 1,N
C           Hamilton Product
            X(1,I) = X(1,I) * ALPHA
            X(2,I) = X(2,I) * CONJG(ALPHA)
  20      CONTINUE
        ENDIF
      ELSE

        IX = 1
        IF ( INCX.LT.0 ) IX = (-N + 1)*INCX + 1

        IF ( .NOT. MRIGHT ) THEN
          DO 30 I = 1,N
C           Hamilton Product
            X(1,IX) = ALPHA * X(1,IX)
            X(2,IX) = ALPHA * X(2,IX)

            IX = IX + INCX
  30      CONTINUE
        ELSE
          DO 40 I = 1,N
C           Hamilton Product
            X(1,IX) = X(1,IX) * ALPHA
            X(2,IX) = X(2,IX) * CONJG(ALPHA)

            IX = IX + INCX
  40      CONTINUE
        ENDIF
      ENDIF
C
      END


module dtypes_module

  use iso_c_binding
  use multifab_module

  implicit none

  integer, parameter :: dim = 2

  integer, parameter :: iu = 1  ! index of population density u
  integer, parameter :: iv = 2  ! index of chemical signal v

  ! chemotaxis context
  type, bind(c) :: cht_ctx_t

     integer(c_int) :: &
          nc = 2, &             ! number of components
          ng = 2, &             ! number of ghost cells
          n_cell = 128          ! number of grid cells

     real(c_double) :: dt, dx, invdx

     real(c_double) :: prob_lo(dim), prob_hi(dim)

     real(c_double) :: &
          diff = 0.1d0, &       ! diffusion constant
          chi  = 5.0d0, &       ! sensitivity constant
          alpha = 0.5d0, &      ! receptor binding constant
          gamma = 10.0d0, &     ! volume filling constant
          phi = 1.0d0           ! saturating chemical production constant

  end type cht_ctx_t

  ! options
  type :: cht_opts_t

     character(len=8) :: method = "sdc" ! integration method: "rk" or "sdc"

     integer :: &
          nsteps = 1000, &      ! number of steps
          plot_int = 100        ! plot interval

  end type cht_opts_t

contains

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine read_namelists(unitno, ctx, opts)
    integer,          intent(in)    :: unitno
    type(cht_ctx_t),  intent(inout) :: ctx
    type(cht_opts_t), intent(inout) :: opts

    character(len=8) :: method
    integer :: n_cell, nsteps, plot_int
    real(8) :: dt

    namelist /options/ method, nsteps, plot_int
    namelist /parameters/ n_cell, dt

    ! read options
    method = opts%method
    nsteps = opts%nsteps
    plot_int = opts%plot_int
    read(unit=unitno, nml=options)
    opts%method = method
    opts%nsteps = nsteps
    opts%plot_int = plot_int

    ! read parameters
    n_cell = ctx%n_cell
    dt = ctx%dt
    read(unit=unitno, nml=parameters)
    ctx%dt = dt
    ctx%n_cell = n_cell

  end subroutine read_namelists

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

end module dtypes_module


!
! this subroutine is used to read some paramters from
! input.dat
! constructed on 4/22/2010 by QS.Wu

  subroutine readinput

     use para
     implicit none

     character*20 :: fname='fitsoc.in'
     character*25 :: char_temp

     logical :: exists
     integer :: i
     integer :: j
     integer :: NN

     real(dp) :: t1

     real(dp) :: temp
     real(dp) :: cell_volume
     real(dp) :: pos(3)

     real(dp) :: k1(3), k2(3)
     real(dp) :: kstart(3), kend(3)

     inquire(file=fname,exist=exists)
     if (exists)then
        write(*,*) 'read some paramters from input.dat'
        open(unit=1001,file=fname,status='old')
     else
        write(*,*)'file ' ,fname, ' dosnot exist'
        stop
     endif

     read(1001,*)infilename(:)
     write(*,'(a,a25)')' input file:',infilename
     read(1001,*)E_fermi
     write(*,*)'E_fermi',E_fermi
     read(1001,*)Nk
     write(*,*)'Nk', Nk

     !> read atom position
     read(1001, *)Num_atoms
     allocate(atom_name(Num_atoms))
     allocate(Atom_position(3, Num_atoms))
     do i=1, Num_atoms
        read(1001, *) atom_name(i), Atom_position(:, i)
        write(*, '(a4,3f6.3)')atom_name(i), Atom_position(:, i)
        pos= Atom_position(:, i)
     enddo

     Num_atom_type= 1
     do i=1, Num_atoms- 1
        if (atom_name(i).ne.atom_name(i+1)) Num_atom_type= Num_atom_type+ 1
     enddo
     print *, Num_atom_type
     allocate(atom_type(Num_atoms))

     Num_atom_type= 1
     atom_type(1)= 1
     do i=1, Num_atoms- 1
        if (atom_name(i).ne.atom_name(i+1)) Num_atom_type= Num_atom_type+ 1
        atom_type(i+1)= Num_atom_type
     enddo

     !> lattice information
     read(1001, *)Rua
     read(1001, *)Rub
     read(1001, *)Ruc

     !> transform lattice from direct space to reciprocal space

     Kua= 0d0
     Kub= 0d0
     Kuc= 0d0
     cell_volume= Rua(1)*(Rub(2)*Ruc(3)- Rub(3)*Ruc(2)) &
                 +Rua(2)*(Rub(3)*Ruc(1)- Rub(1)*Ruc(3)) &
                 +Rua(3)*(Rub(1)*Ruc(2)- Rub(2)*Ruc(1))
     cell_volume= 2d0*3.1415926535d0/cell_volume
     Kua(1)= cell_volume*(Rub(2)*Ruc(3)- Rub(3)*Ruc(2))
     Kua(2)= cell_volume*(Rub(3)*Ruc(1)- Rub(1)*Ruc(3))
     Kua(3)= cell_volume*(Rub(1)*Ruc(2)- Rub(2)*Ruc(1))

     Kub(1)= cell_volume*(Ruc(2)*Rua(3)- Ruc(3)*Rua(2))
     Kub(2)= cell_volume*(Ruc(3)*Rua(1)- Ruc(1)*Rua(3))
     Kub(3)= cell_volume*(Ruc(1)*Rua(2)- Ruc(2)*Rua(1))

     Kuc(1)= cell_volume*(Rua(2)*Rub(3)- Rua(3)*Rub(2))
     Kuc(2)= cell_volume*(Rua(3)*Rub(1)- Rua(1)*Rub(3))
     Kuc(3)= cell_volume*(Rua(1)*Rub(2)- Rua(2)*Rub(1))

     write(*, '(a)') '>> lattice information'
     write(*, '(3f10.6)')Rua
     write(*, '(3f10.6)')Rub
     write(*, '(3f10.6)')Ruc

     write(*, '(a)') '>> Reciprocal lattice information'
     write(*, '(3f10.6)')Kua
     write(*, '(3f10.6)')Kub
     write(*, '(3f10.6)')Kuc

     !> kline for 3d band structure
     !> high symmetry k points
     read(1001, *) nk3lines
     allocate(k3line_start(3, nk3lines))
     allocate(k3line_end(3, nk3lines))
     allocate(k3line_name(nk3lines+1))
     allocate(k3line_stop(nk3lines+1))
     k3line_stop= 0d0
     k3line_start= 0d0
     k3line_end= 0d0
     k3line_name= ' '
     do i=1, nk3lines
        read(1001, *) k3line_name(i), k3line_start(:, i), &
                      char_temp, k3line_end(:, i)
     enddo
     k3line_name(nk3lines+1)= char_temp

     NN= Nk
     nk3_band= NN*nk3lines
     allocate(k3len(nk3_band))
     allocate(k3points(3, nk3_band))
     k3len=0d0
     k3points= 0d0
     t1= 0d0
     do j=1, nk3lines
        do i=1, NN
           kstart= k3line_start(:, j)
           kend  = k3line_end(:, j)
           k1= kstart(1)*Kua+ kstart(2)*Kub+ kstart(3)*Kuc
           k2= kend(1)*Kua+ kend(2)*Kub+ kend(3)*Kuc

           k3points(:, i+ (j-1)*NN)= kstart+ (kend- kstart)*dble(i-1)/dble(NN-1)

           temp= dsqrt((k2(1)- k1(1))**2 &
                 +(k2(2)- k1(2))**2  &
                 +(k2(3)- k1(3))**2)/dble(NN-1)

           if (i.gt.1) then
              t1=t1+temp
           endif
           k3len(i+(j-1)*NN)= t1
        enddo
        k3line_stop(j+1)= t1
     enddo

     !> read projectors
     allocate(nprojs(Num_atoms))
     nprojs= 0
     read(1001, *)nprojs

     max_projs= maxval(nprojs)
     allocate(proj_name(max_projs, Num_atoms))
     proj_name= ' '
     do i=1, Num_atoms
        read(1001, *)char_temp, proj_name(1:nprojs(i), i)
        write(*, '(100a6)') char_temp, proj_name(1:nprojs(i), i)
     enddo

     !> spin orbital coupling strength
     allocate(lambda_p(Num_atom_type))
     allocate(lambda_d(Num_atom_type))
     lambda_p= 0d0
     lambda_d= 0d0
     read(1001, *) lambda_p(:)
     write(*, '(a,100f7.4)')'lambda_p input', lambda_p
     read(1001, *) lambda_d(:)
     write(*, '(a,100f7.4)')'lambda_d input', lambda_d

     write(*,*)'read input.dat file successfully'

     return
  end subroutine


      subroutine csomm (dr,dp,dq,dpas,da,m,np)
c Modified to use complex p and q.  SIZ 4/91
c integration by the method of simpson of (dp+dq)*dr**m from
c 0 to r=dr(np)
c dpas=exponential step;
c for r in the neighborhood of zero (dp+dq)=cte*r**da
c **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(*)
      complex*16  dp(*),dq(*),da,dc
      mm=m+1
      d1=da+mm
      da=0.0
      db=0.0
      do 70 i=1,np
      dl=dr(i)**mm
      if (i.eq.1.or.i.eq.np) go to 10
      dl=dl+dl
      if ((i-2*(i/2)).eq.0) dl=dl+dl
   10 dc=dp(i)*dl
      da=da+dc
      dc=dq(i)*dl
      da=da+dc
   70 continue
      da=dpas*da/3
      dd=exp(dpas)-1.0
      db=d1*(d1+1.0)*dd*exp((d1-1.0)*dpas)
      db=dr(1)*(dr(2)**m)/db
      dd=(dr(1)**mm)*(1.0+1.0/(dd*(d1+1.0)))/d1
      da=da+dd*(dp(1)+dq(1))-db*(dp(2)+dq(2))
      return
      end


! jcarron March 2021
module gl
    implicit none
    double precision, parameter :: ATOL=1e-15, RTOL=1e-15, PI_4=0.78539816339744831d0, PI_SGL=3.141592654d0
    double precision, parameter :: stirling(1:10) = (/    1.0d0, 0.08333333333333333d0, 0.003472222222222222d0, &
                                    -0.0026813271604938273d0,   -0.00022947209362139917d0, 0.0007840392217200666d0,&
                                    6.972813758365857d-5, -0.0005921664373536939d0,  -5.171790908260592d-5,&
                                    0.0008394987206720873d0/) ! Stirlings expansion parameters
    contains

        subroutine startz(n, k, z) ! first guess at root number k
            implicit none
            integer, intent(in) :: n, k
            double precision, intent(out) :: z
            double precision cosk
            ! This works just fine for all.
             z = dcos(PI_SGL*(k-0.25d0)/(n+0.5d0)) * (1.d0 - (n-1) / (2.d0 * n) ** 3) !pi not double precision on purpose
        end subroutine startz

        double precision function glnorm(n)
            ! This is just Gamma(n + 1) / Gamma (n + 1 + 1/2) sqrt{4\pi} in double precision really
            ! Turned out accurate enough calc of this prefactor failed even with loggamma.
            implicit none
            integer, intent(in) :: n  ! intention is here always larger than 200
            double precision an, ni, n12i, s, s12, t
            integer i
            s = 1.d0
            s12 = 1.d0
            ni = 1.d0
            n12i = 1.d0
            do i = 2, 10
                ni = ni / n
                n12i = n12i / (n + 0.5d0)
                s = s + stirling(i) * ni
                s12 = s12 + stirling(i) * n12i
            end do
            t = 0.d0
            an = 1.d0
            do i = 1, 10, 2
                an = an  / (2 * n)
                t = t - an / i
                an = an / (2 * n)
                t = t + an / (i + 1)
            end do
            glnorm =  dsqrt(dexp(1.d0) / (n + 0.5d0)) * s / s12 * dexp((n + 0.5d0) * t) / dsqrt(PI_4)
        end function glnorm

        subroutine legphn(n, k, th, norm, m, pn, pp)
            !Superfast evaluation of Legendre polynomials for high (> 100) n
            implicit none
            double precision, intent(in) :: th, norm  ! not cos(th); norm is the precomputed amma(n + 1) / Gamma(n + 3/2) (tricky)
            integer, intent(in) :: n, k  ! k: root index (see startz above)
            integer, intent(out) :: m
            double precision, intent(out) :: pn, pp
            double precision cn, an, cth, sth, coth, dth, sth2,  coeff, coeff1, incrp, cosm, sinm, cosm1, sinm1

            cth = dcos(th)
            sth = dsin(th)
            coth = cth / sth
            sth2 = 2d0 * sth
            cn = norm ! same for all points
            cn = cn / dsqrt(sth2)

            ! we always expect the argument below to be k pi  + O(1/n^2) correction.
            ! The error in the sign term will give an error in the derivative -> weights
            dth = th - 4d0 * PI_4*(k-0.25d0)/(n+0.5d0)  ! this should always be very small (1/n^2) ?

            !cosm = dcos( (n + 0.5d0) * th - PI_4)    k pi - pi/2 + (n+1/2)dth
            !sinm = dsin( (n + 0.5d0) * th - PI_4)    k pi - pi/2 + (n+1/2)dth
            sinm = -dcos( (n + 0.5d0) * dth)  ! no large argument here but ~ 1/n,
            cosm =  dsin( (n + 0.5d0) * dth)  ! no large argument here but ~ 1/n
            if (BTEST(k, 0)) then ! sign if k odd
                sinm = -sinm
                cosm = -cosm
            end if
            coeff  = cn
            incrp = coeff * (n * sinm  +  0.5d0 * (coth * cosm + sinm))
            m = 0
            pn = 0.d0
            pp = 0.d0
            an = 1.d0
            do while ( ((coeff > (ATOL * 0.5)) .or. (abs(incrp/pp) > RTOL)) .and. (m < 1000 ))
                pn = pn + coeff * cosm
                pp = pp + incrp ! first derivative dPn / dtht
                m = m + 1
                an = an * (m - 0.5d0) ** 2 / m / (n + m + 0.5d0) / sth2
                cosm1 = cosm * sth + sinm * cth
                sinm1 = sinm * sth - cosm * cth
                cosm = cosm1  ! cos( n+1/2 th + m(th -pi/2) - pi/4)
                sinm = sinm1
                coeff = cn * an
                incrp = coeff * (n * sinm  +  (m + 0.5d0) * (coth * cosm + sinm)) ! there is a typo in the reference paper in the hn-1 -> hn equation
            end do
            pp = -pp
        end subroutine legphn

        subroutine legp(n, x, pn, pp) ! standard 3 terms rec for Pn and dPn / d cth
        implicit none
        double precision, intent(in) :: x  ! cos(tht)
        integer, intent(in) :: n
        double precision, intent(out) :: pn, pp
        double precision p2, p3
        integer j
        pn = 1.0d0
        p2 = 0.0d0
        do j=1,n
            p3 = p2
            p2 = pn
            pn = ((2*j-1)*x*p2-(j-1)*p3)/j
        end do
        pp = n*(x*pn-p2)/(x*x-1)
        end subroutine legp

end module gl

subroutine get_xgwg(x1, x2, x, w, n)
    ! Gauss-Legendre quadrature points and weights.
    ! Algorithm scaling linearly with number of points, using super-fast high-n expansion of Legendre Pol.
    ! (adapted from Hale and Townsend 2013)
    ! I see ~10ms for N~10000
  use gl, only: legp, legphn, startz, glnorm
  implicit none
  integer, intent(in) :: n
  double precision, intent(in) :: x1, x2
  double precision, dimension(n), intent(out) :: x, w
  integer :: i, j, m, mi, it
  double precision :: p1, p2, p3, pp, xl, xm, z, z1, th, th1, norm
  double precision, parameter :: eps=1d-15
  m = (n+1)/2
  if (n < 200) then
      mi = m
  else
      mi = 50
  end if
  xm = 0.5d0*(x2+x1)
  xl = 0.5d0*(x2-x1)
  ! exterior region: (this should dominate the errors; did not bother to change that)
  do i=1, mi
    call startz(n, i, z)
    z1 = 0.d0
    do while(abs(z-z1) > eps)
        call legp(n, z, p1, pp)
        z1 = z
        z = z1 - p1/pp
    end do
    x(i) = xm - xl*z
    x(n+1-i) = xm + xl*z
    w(i) = (2*xl)/((1-z*z)*pp*pp)
    w(n+1-i) = w(i)
  end do
  ! Interior region: (following Hale and Townsend. Really fast.
  norm = glnorm(n)
  do i=mi + 1, m
    call startz(n, i, z)
    th = dacos(z)
    th1 = 0.d0
    do while(abs(th-th1) > eps)
        call legphn(n, i, th, norm, it, p1, pp)
        th1 = th
        th = th1 - p1/ pp
    end do
    z = cos(th)
    x(i) = xm - xl*z
    x(n+1-i) = xm + xl*z
    w(i) = (2*xl)/(pp*pp) ! now pp is d/dth, not d/dcth
    w(n+1-i) = w(i)
  end do
end subroutine get_xgwg

module gridutils
    implicit none
    double precision, parameter :: SYMTOL=1e-14
    contains
        logical function symgrid(x, nx)
            ! assuming here for most if not all of my applications is either not at all or fully symmetric
            implicit none
            integer, intent(in) :: nx
            double precision, intent(in) :: x(nx)
            integer ix
            ix = 0
            symgrid = nx > 1
            do while(symgrid .and. (ix < nx/2 + 1))
                ix = ix + 1
                symgrid = symgrid .and. ( abs((x(ix) + x(nx - (ix - 1)))) < SYMTOL)
            end do
        end function symgrid
end module gridutils

module jacobi
    implicit none
    contains
    subroutine rescal_jacobi(s1, s2, lmax, rl)
        ! coefficients turning Jacobi polynomials onto Wigner small d's
        ! ~0.1 ms at most for high lmax
        ! These coeffs are (for integer a, b)
        ! ( (k + (a + b)) ! * k ! / (k + a)! / (k + b)! )^1/2
        implicit none
        integer, intent(in) :: s1, s2
        integer, intent(in) :: lmax
        double precision, intent(out) :: rl(0:lmax - max(abs(s1), abs(s2)))
        integer a, b, lmin, k
        double precision dmab

        a = abs(s1 - s2)
        b = abs(s1 + s2)
        lmin = max(abs(s1), abs(s2))
        dmab = max(a, b)
        rl(0) = 1d0
        do k = 1, min(a, b)
            rl(0) = rl(0) * dsqrt(1.d0 + dmab / k)
        end do
        do k = 0, lmax - lmin - 1
            rl(k + 1) = rl(k) * dsqrt(  (k + 1.d0 + (a + b) ) / (k + 1.d0 + a) * (k + 1.d0) / (k + 1.d0 + b))
        end do
    end subroutine rescal_jacobi

    subroutine anbncn_jacobi(a, b, lmax, an, bn, cn)
        !Returns 3-terms recursion relation coefficients for Jacobi Polynomials
        ! ~0.1ms at most even for high lmax
        implicit none
        integer, intent(in) :: lmax
        double precision, intent(in) :: a, b
        double precision apb
        integer il
        double precision, intent(out):: an(0:lmax-1), bn(0:lmax-1), cn(0:lmax-1)
        apb = a + b
        cn(0) = 0.
        an(0) = (1 + apb) / 2 * (2 + apb) / (1 + apb)
        do il = 1, lmax - 1
            an(il) = (2 * il + 1 + apb) / (2 * (il + 1)) * (2 * il + 2 + apb) / (il + 1 + apb)
            cn(il) = (il + a) * (il + b) / (il + 1) * (2 * il + 2 + apb) / (il + 1 + apb) / (2 * il + apb)
        end do
        if (abs(a) == abs(b)) then
            bn = 0.d0
        else
            do il = 0, lmax - 1
              bn(il) = 0.5d0 * apb * (a - b) * (2 * il + 1 + apb) / (il + 1) / (2 * il + apb) / (il + 1 + apb)
            end do
        end if
    end subroutine anbncn_jacobi
end module jacobi

module poly
    implicit none
    contains

        subroutine rescal_coeff(lmax, an, bn, cn, rn)
        !Arranges the 3-terms recurence coefficients if the wanted polynmomials are rescaled versions of the original coeffs.
        !This assumes lmax > 0
        implicit none
        double precision an(0:lmax-1), bn(0:lmax-1), cn(0:lmax-1), rn(0:lmax)
        integer lmax, l
        double precision rab(0:lmax-1), rc(0:lmax-1)

        do l = 0, lmax - 1
            rab(l) = rn(l + 1) / rn(l)
        end do
        rc(0) = 0.
        do l = 1, lmax -1
            rc(l) = rn(l + 1) / rn(l - 1)
        end do
        an = an * rab
        bn = bn * rab
        cn = cn * rc
        end subroutine rescal_coeff

        subroutine pol2pos(xi, nx, lmax, x, an, bn, cn, cl, p0)
            ! Computes position space \sum_l cl Pl(x) without openMP threading
            ! Ortho polynomial eval up to lmax with 3 term recurrence relation
            ! P_{n+1}(x) = (a_n x + b_n) P_{n}(x) - c_n P_{n-1}(x) (Andrews, Askey and Roy)
            ! Normalization for ortho pol can also be gained from recurrence relation (see same ref)
            implicit none
            double precision, intent(in) :: x(nx)
            double precision, intent(in) :: an(0:lmax-1), bn(0:lmax-1), cn(0:lmax-1), cl(0:lmax)
            double precision, intent(out) :: xi(nx)
            double precision :: pl(nx), plp1(nx), plm1(nx), p0
            integer, intent(in) :: nx, lmax
            integer :: l

            if (lmax == 0) then
                xi = cl(0) * p0
                return
            end if
            plm1 = 0.
            pl = p0
            plp1 = (an(0) * x + bn(0)) * pl
            xi = cl(0) * pl + cl(1) * plp1
            do l = 1, lmax - 1
                plm1 = pl
                pl = plp1
                plp1 = (an(l) * x + bn(l)) * pl - cn(l) * plm1
                xi = xi + plp1 * cl(l + 1)
            end do
        end subroutine pol2pos

        subroutine pol2pos_omp(xi, nx, lmax, x, an, bn, cn, cl, p0)
            ! Computes position space \sum_l cl Pl(x) with openMP
            ! Ortho polynomial eval up to lmax with 3 term recurrence relation
            ! P_{n+1}(x) = (a_n x + b_n) P_{n}(x) - c_n P_{n-1}(x) (Andrews, Askey and Roy)
            ! Normalization for ortho pol can also be gained from recurrence relation (see same ref)
            implicit none
            double precision, intent(in) :: x(nx)
            double precision, intent(in) :: an(0:lmax-1), bn(0:lmax-1), cn(0:lmax-1), cl(0:lmax)
            double precision, intent(out) :: xi(nx)
            double precision :: pl, plp1, plm1, p0, txi
            integer, intent(in) :: nx, lmax
            integer :: l, ix

            if (lmax == 0) then
                xi = cl(0) * p0
                return
            end if
        !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ix, txi, plm1, pl, plp1, l) SHARED(xi, x, lmax, an, bn, cn, cl, p0, nx)
            do ix = 1, nx
                plm1 = 0.
                pl = p0
                plp1 = (an(0) * x(ix) + bn(0)) * pl
                txi = cl(0) * pl + cl(1) * plp1
                do l = 1, lmax - 1
                    plm1 = pl
                    pl = plp1
                    plp1 = (an(l) * x(ix) + bn(l)) * pl - cn(l) * plm1
                    txi = txi + plp1 * cl(l + 1)
                end do
                xi(ix) = txi
            end do
        !$OMP END PARALLEL DO
        end subroutine pol2pos_omp

        subroutine pol2pos_omp_zsym(xi, nx, lmax, x, an, bn, cn, cl, p0)
            ! Computes position space \sum_l cl Pl(x) with openMP
            ! Ortho polynomial eval up to lmax with 3 term recurrence relation
            ! P_{n+1}(x) = (a_n x + b_n) P_{n}(x) - c_n P_{n-1}(x) (Andrews, Askey and Roy)
            ! Normalization for ortho pol can also be gained from recurrence relation (see same ref)
            ! This version fills half of the array assuming x(i) = -x(N-i) and Pl(1-x) = (-1)^l Pl(x) for a ~ factor of 2 speedup
            implicit none
            double precision, intent(in) :: x(nx)
            double precision, intent(in) :: an(0:lmax-1), bn(0:lmax-1), cn(0:lmax-1), cl(0:lmax)
            double precision, intent(out) :: xi(nx)
            double precision :: pl, plp1, plm1, p0, txi_p, txi_m
            integer, intent(in) :: nx, lmax
            integer :: l, ix

            if (lmax == 0) then
                xi = cl(0) * p0
                return
            end if
        !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ix, txi_p, txi_m, plm1, pl, plp1, l) SHARED(xi, x, nx, lmax, an, bn, cn, cl, p0)
            do ix = 1, nx / 2 + MOD(nx, 2)
                plm1 = 0.
                pl = p0
                plp1 = (an(0) * x(ix) + bn(0)) * pl
                txi_p = cl(0) * pl   ! collects even multipoles only
                txi_m = cl(1) * plp1 ! collects odd mutipoles only
                do l = 1, lmax - 1
                    plm1 = pl
                    pl = plp1
                    plp1 = (an(l) * x(ix) + bn(l)) * pl - cn(l) * plm1
                    if ( BTEST(l, 0) ) then  ! same as ( mod(l, 2) > 0)
                        txi_p = txi_p + plp1 * cl(l + 1)
                    else
                        txi_m = txi_m + plp1 * cl(l + 1)
                    end if
                end do
                xi(ix) = txi_p + txi_m
                xi(nx - (ix - 1)) = txi_p - txi_m
            end do
        !$OMP END PARALLEL DO
        end subroutine pol2pos_omp_zsym

        subroutine pol2pos_clshw_omp(xi, nx, lmax, x, an, bn, cn, cl, p0)
            ! Computes position space \sum_l cl Pl(x)
            ! Ortho polynomial eval up to lmax with 3 term recurrence relation
            ! P_{n+1}(x) = (a_n x + b_n) P_{n}(x) - c_n P_{n-1}(x) (Andrews, Askey and Roy)
            ! Normalization for ortho pol can also be gained from recurrence relation (see same ref)
            ! This ues clenshaw recurrence
            ! Seems speedwise equivalent or sligthly worse than the forward scheme...
            implicit none
            double precision, intent(in) :: x(nx)
            double precision, intent(in) :: an(0:lmax-1), bn(0:lmax-1), cn(0:lmax-1), cl(0:lmax)
            double precision, intent(out) :: xi(nx)
            double precision :: yl, ylp1, ylp2, p0, tx
            integer, intent(in) :: nx, lmax
            integer :: l, ix
            if (lmax == 0) then
                xi = p0 * cl(0)
                return
            else if (lmax == 1) then
                xi = p0 * (cl(0) + cl(1) * (an(0) * x(ix) + bn(0)))
                return
            end if
        !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ix, tx, yl, ylp1, ylp2, l) SHARED(xi, x, p0, nx, lmax, an, bn, cn, cl)
            do ix = 1, nx
                tx = x(ix)
                ylp2 = cl(lmax)  ! lmax
                ylp1 = (an(lmax - 1) * tx + bn(lmax - 1)) * ylp2 + cl(lmax - 1)  ! lmax - 1
                do l = lmax - 2, 1, -1
                    yl = (an(l) * tx + bn(l)) * ylp1 - cn(l+1) * ylp2 + cl(l)
                    ylp2 = ylp1
                    ylp1 = yl
                end do
                xi(ix) = p0 * (-cn(1) * ylp2 +  (an(0) * tx + bn(0)) * ylp1 + cl(0))
            end do
        !$OMP END PARALLEL DO
        end subroutine pol2pos_clshw_omp

        subroutine pos2pol(xi, nx, lmax, x, an, bn, cn, cl, p0, kmax)
            ! here lmax is not same as Jacobi's kmax, we fill cl up to lmax
            implicit none
            double precision, intent(in) :: x(nx)
            integer, intent(in) :: nx, lmax, kmax
            double precision, intent(in) :: an(0:kmax-1), bn(0:kmax-1), cn(0:kmax-1), xi(nx)
            double precision, intent(out) :: cl(0:lmax)
            double precision :: pl(nx), plp1(nx), plm1(nx), p0(nx)
            integer :: k, lmin
            if (kmax > lmax) then
                write(*, *) 'incompatible Wigner and Jacobi limits'
                error stop
            end if

            lmin = lmax - kmax
            cl(0:lmin-1) = 0.d0
            cl(lmin) = sum(xi * p0)
            if (lmax == lmin) then
                return
            end if
            pl = p0
            plp1 = (an(0) * x + bn(0)) * pl
            cl(lmin + 1) = sum(plp1 * xi)
            do k = 1, kmax - 1
                plm1 = pl
                pl = plp1
                plp1 = (an(k) * x + bn(k)) * pl - cn(k) * plm1
                cl(lmin + k + 1) = sum(plp1 * xi)
            end do
        end subroutine pos2pol

        subroutine pos2pol_omp(xi, nx, lmax, x, an, bn, cn, cl, p0, kmax)
            ! here lmax should not be confused with Jacobi's kmax, we fill cl up to lmax
            implicit none
            double precision, intent(in) :: x(nx)
            integer, intent(in) :: nx, lmax, kmax
            double precision, intent(in) :: an(0:kmax-1), bn(0:kmax-1), cn(0:kmax-1), xi(nx)
            double precision, intent(out) :: cl(0:lmax)
            double precision :: pl, plp1, plm1, p0(nx), cl_priv(0:kmax - 1)
            integer :: k, lmin, ix
            if (kmax > lmax) then
                write(*, *) 'incompatible Wigner and Jacobi limits'
                error stop
            end if

            cl = 0.d0
            lmin = lmax - kmax
            cl(lmin) = sum(xi * p0)
            if (lmax == lmin) then
                return
            end if
        !$OMP PARALLEL DEFAULT(NONE) PRIVATE(k, ix, plm1, pl, plp1, cl_priv) SHARED(lmin, x, xi, nx, kmax, p0, an, bn, cn, cl)
            cl_priv = 0.
        !$OMP DO
            do ix = 1, nx
                pl = p0(ix)
                plp1 = (an(0) * x(ix) + bn(0)) * pl
                cl_priv(0) = cl_priv(0) + plp1 * xi(ix)
                do k = 1, kmax - 1
                    plm1 = pl
                    pl = plp1
                    plp1 = (an(k) * x(ix) + bn(k)) * pl - cn(k) * plm1
                    cl_priv(k) = cl_priv(k) + plp1 * xi(ix)
                end do
            end do
        !$OMP END DO
        !$OMP CRITICAL
            cl(lmin +1:) = cl(lmin + 1:) + cl_priv
        !$OMP END CRITICAL
        !$OMP END PARALLEL

        end subroutine pos2pol_omp

        subroutine pos2pol_omp_zsym(xi, nx, lmax, x, an, bn, cn, cl, p0, kmax)
            ! here lmax should not be confused with Jacobi's kmax, we fill cl up to lmax
            ! This version fills the array assuming x(i) = -x(N-i) and Pl(1-x) = (-1)^l Pl(x) for a ~ factor of 2 speedup
            use gridutils, only : SYMTOL
            implicit none
            double precision, intent(in) :: x(nx)
            integer, intent(in) :: nx, lmax, kmax
            double precision, intent(in) :: an(0:kmax-1), bn(0:kmax-1), cn(0:kmax-1), xi(nx)
            double precision, intent(out) :: cl(0:lmax)
            double precision :: pl, plp1, plm1, p0(nx), clp1(0:kmax - 1), clp2(0:kmax - 1)
            integer :: k, lmin, ix
            if (kmax > lmax) then
                write(*, *) 'incompatible Wigner and Jacobi limits'
                error stop
            end if
            cl = 0.d0
            lmin = lmax - kmax
            cl(lmin) = sum(xi * p0)
            if (lmax == lmin) then
                return
            end if
        !$OMP PARALLEL DEFAULT(NONE) PRIVATE(k, ix, plm1, pl, plp1, clp1, clp2) SHARED(lmin, x, xi, nx, kmax, p0, an, bn, cn, cl)
            clp1 = 0.
            clp2 = 0.
        !$OMP DO
            do ix = 1, nx / 2
                pl = p0(ix)
                plp1 = (an(0) * x(ix) + bn(0)) * pl
                clp1(0) = clp1(0) + plp1 * xi(ix)
                clp2(0) = clp2(0) + plp1 * xi(nx - (ix-1))
                do k = 1, kmax - 1
                    plm1 = pl
                    pl = plp1
                    plp1 = (an(k) * x(ix) + bn(k)) * pl - cn(k) * plm1
                    clp1(k) = clp1(k) + plp1 * xi(ix)
                    clp2(k) = clp2(k) + plp1 * xi(nx - (ix - 1))
                end do
            end do
        !$OMP END DO
            do k = 0, kmax -1, 2 !parity flip for odd Jacobi multipoles (first entry corresponds to P_{n=1})
                clp2(k) = -clp2(k)
            end do
            clp1 = clp1 + clp2
        !$OMP CRITICAL
            cl(lmin +1:) = cl(lmin + 1:) + clp1
        !$OMP END CRITICAL
        !$OMP END PARALLEL
            ! adding the zero entry if present:
            if ( BTEST(nx, 0) ) then !same as mod(nx, 2) > 0
                ix = nx / 2 + 1
                if (abs(x(ix)) > SYMTOL) then
                    write(*, *) 'This should not have passed the symmetry scan'
                    error stop
                end if
                pl = p0(ix)  ! same as before with x = 0
                plp1 = bn(0) * pl
                cl(lmin + 1) = cl(lmin + 1)  + plp1 * xi(ix)
                do k = 1, kmax - 1
                    plm1 = pl
                    pl = plp1
                    plp1 = bn(k) * pl - cn(k) * plm1
                    cl(lmin + 1 + k) = cl(lmin + 1 + k) + plp1 * xi(ix)
                end do
            end if
        end subroutine pos2pol_omp_zsym

end module poly

subroutine wignerpos(xi, nx, lmax, cl, x, s1, s2)
    use gridutils, only: symgrid
    use jacobi, only:anbncn_jacobi, rescal_jacobi
    use poly, only: rescal_coeff, pol2pos, pol2pos_omp, pol2pos_omp_zsym
    implicit None
    double precision, intent(in) :: x(nx), cl(0:lmax)
    double precision, intent(out) :: xi(nx)
    integer, intent(in) :: s1, s2, nx, lmax
    double precision rn(0:lmax-max(abs(s1), abs(s2)))
    double precision an(0:lmax-max(abs(s1), abs(s2)) - 1)
    double precision bn(0:lmax-max(abs(s1), abs(s2)) - 1)
    double precision cn(0:lmax-max(abs(s1), abs(s2)) - 1)
    double precision a, b, p0, clm(0:lmax - max(abs(s1), abs(s2)))
    double precision, parameter :: PI4_i = 0.07957747154594767d0
    integer lmin, l, ix
    logical zsym

    lmin = max(abs(s1), abs(s2))
    if (lmin > lmax) then
        xi = 0.d0
        return
    end if
    !Jacobi Pol. parameters:
    a = abs(s1 - s2)
    b = abs(s1 + s2)
    ! Do I face a symmetric grid?
    ! one of the spin must be at least zero and we can use symmetry if the x grid is, with a plain factor of 2 gain
    zsym = (a == b) .and. (symgrid(x, nx))
    do l = lmin, lmax ! cl to pass against the Jacobi polynomials
        clm(l-lmin) = cl(l) * (2 * l + 1) * PI4_i !  cl (2l + 1) / 4pi
    end do
    p0 = 1.d0
    call anbncn_jacobi(a, b, lmax-lmin, an, bn, cn) ! Jacobi 3-terms recursion coefficients
    if (lmin > 0) then !at least one spin non-zero, we must rescale
        call rescal_jacobi(s1, s2, lmax, rn)
        if (lmax > lmin) then
            call rescal_coeff(lmax-lmin, an, bn, cn, rn)
        end if
        p0 = p0 * rn(0)
    end if
    if (zsym) then
        call pol2pos_omp_zsym(xi, nx, lmax-lmin, x, an, bn, cn, clm, p0)
    else
        if (nx > 1) then ! in principle, nx either 1 or very large here...
            call pol2pos_omp(xi, nx, lmax-lmin, x, an, bn, cn, clm, p0)
        else
            call pol2pos(xi, nx, lmax-lmin, x, an, bn, cn, clm, p0)
        end if
    end if
    if (a > 0) then
        xi = xi * (0.5 * (1 - x) ) ** (a * 0.5d0)  ! sin(x/2) ** a/2
    end if
    if (b > 0) then
        xi = xi * (0.5 * (1 + x) ) ** (b * 0.5d0)  ! cos(x/2) ** b/2
    end if
    if ( (s1 > s2) .AND. (BTEST(s1-s2, 0))) then
        xi = xi * (-1)
    end if
end subroutine wignerpos

subroutine wignercoeff(cl, xi, x, s1, s2, lmax, nx)
    use gridutils, only : symgrid
    use jacobi, only:anbncn_jacobi, rescal_jacobi
    use poly, only: pos2pol_omp, pos2pol_omp_zsym, rescal_coeff
    implicit None
    double precision, intent(in) :: x(nx), xi(nx)
    double precision, intent(out) :: cl(0:lmax)
    integer, intent(in) :: s1, s2, nx, lmax
    double precision rn(0:lmax-max(abs(s1), abs(s2)))
    double precision an(0:lmax-max(abs(s1), abs(s2)) - 1)
    double precision bn(0:lmax-max(abs(s1), abs(s2)) - 1)
    double precision cn(0:lmax-max(abs(s1), abs(s2)) - 1)
    double precision p0(nx)
    double precision a, b
    double precision, parameter :: PI2 = 6.283185307179586d0
    integer lmin, l, ix
    logical zsym

    lmin = max(abs(s1), abs(s2))
    if (lmin > lmax) then
        cl = 0.d0
        return
    end if
    ! alpha and beta parameter of the Jacobi pol.
    a = abs(s1 - s2)
    b = abs(s1 + s2)
    ! Do I have a symmwetric xcolat grid?
    ! one of the spin at least is zero and we can use symmetry if the x grid is, with a plain factor of 2 gain
    zsym = (a == b) .and. (symgrid(x, nx))
    ! builds Jacobi 3-terms recursion coefficients:
    call anbncn_jacobi(a, b, lmax-lmin, an, bn, cn)
    ! Construction of the order zeroth Wigner polynomial in three steps:
    if ( (s1 > s2) .AND. (mod(s1-s2, 2) == 1) ) then
        p0 = -PI2
    else
        p0 = PI2
    end if
    if (a > 0) then
        p0 = p0 * (0.5 * (1 - x) ) ** (a * 0.5d0)  ! sin(x/2) ** a/2
    end if
    if (b > 0) then
        p0 = p0 * (0.5 * (1 + x) ) ** (b * 0.5d0)  ! cos(x/2) ** b/2
    end if
    if (lmin > 0) then !at least one spin non-zero. We need to rescal Jacobi polynomials
        call rescal_jacobi(s1, s2, lmax, rn)
        p0 = p0 * rn(0)
        if (lmax > lmin) then
            call rescal_coeff(lmax-lmin, an, bn, cn, rn)
        end if
    end if
     ! Supercrude split to decide which version of pos2pol to use.  In principle nx is always very large here...
    if (zsym) then
        call pos2pol_omp_zsym(xi, nx, lmax, x, an, bn, cn, cl, p0, lmax-lmin)
    else
        call pos2pol_omp(xi, nx, lmax, x, an, bn, cn, cl, p0, lmax-lmin)
    end if
end subroutine wignercoeff


      subroutine runCY_000000l(k,l,Xtwiddle,Gtwiddle,Shat7zzzz,N0)
      implicit none
C---  Expression for extension of Eq. 5.60a
C---  Calculates C00llll
C---  Small terms of order Xtwiddle(0,k)*Ciiiii,Xtwiddle(0,0)*Ciiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7zzzz(np,z2max,-2:0)

      do ep=-2,0
      Cv(czzzzzzi(l)+N0,ep)=
     . (Gtwiddle(k,1)*Shat7zzzz(1,z2(l,l),ep)
     . +Gtwiddle(k,2)*Shat7zzzz(2,z2(l,l),ep)
     . +Xtwiddle(k,0)*Cv(czzzzii(z2(l,l))+N0,ep)
     . -Xtwiddle(0,0)*Cv(czzzziii(z3(k,l,l))+N0,ep))
     . /(4d0*Gtwiddle(k,l))
      enddo

      return
      end


      SUBROUTINE BESIZ (ZIN,M,IOM,IRP,GJIM,GJIN,GYKM,GYKN,LERR)
C
C     ORDINARY AND MODIFIED BESSEL FUNCTIONS OF INTEGRAL ORDER
C     FOR COMPLEX ARGUMENT
C
C     COMPLEX VARIABLE NOTATION     (I = SQUARE ROOT OF -1)
C
C (IN ) RECTANGULAR COORDINATES  -  Z = X+I*Y, PHI = X, CHI = Y
C (IN ) POLAR COORDINATES  -  Z = RHO*COS(ANGLE)+I*RHO*SIN(ANGLE)
C (IN )                    -  PHI = RHO,  THE RADIUS VECTOR
C (IN )                    -  CHI = ANGLE IN DEGREES
C (IN )                    -  180 < CHI <= 180  (PROGRAM CORRECTS)
C (IN ) M  = ORDER TO BE COMPUTED - PROGRAM COMPUTES ORDERS M AND M+1.
C (IN )        EX.  IF N = M+1 THEN WILL GIVE JM(Z) AND JN(Z)
C (IN ) IOM = 1  COMPUTE ORDINARY BESSEL FUNCTIONS
C (IN ) IOM = 2  COMPUTE MODIFIED BESSEL FUNCTIONS
C (IN ) IRP = 1  ARGUMENT IS IN RECTANGULAR COORDINATES
C (IN ) IRP = 2  ARGUMENT IS IN POLAR COORDINATES - ANGLE IN DEGREES
C
C (OUT) GJIM,GJIN - BESSEL FUNCTIONS OF THE FIRST KIND
C (OUT)     GJIM = JM(Z) OR IM(Z)
C (OUT)     GJIN = JN(Z) OR IN(Z)
C (OUT) GYKM,GYKN - BESSEL FUNCTIONS OF THE SECOND KIND
C (OUT)     GYKM = YM(Z) OR KM(Z)
C (OUT)     GYKN = YN(Z) OR KN(Z)
C
C (OUT) LERR IS AN INTEGER INDICATING IF THERE WAS A RUN ERROR IN THE
C (OUT)      SUBROUTINE.  LERR = 0, NO ERROR.  LERR > 1, THERE WAS AN
C (OUT)      ERROR.  USER CAN TEST THIS NUMBER AND THEN DECIDE WHETHER
C (OUT)      TO CONTINUE OR NOT.
C
      REAL EPSI(9)
      COMPLEX JIM,YKM,JIN,YKN,Z,ZL,OH,X,Y,CM1,CN1,CM2,CN2,
     1 CM3,CN3,CM4,CN4,T,TM(100),TN(100),TV(100),TW(100),
     2 ST,SU,SV,SW,GJIM,GJIN,GYKM,GYKN,
     3 JHN1,JHM1,JHM,SJM1,SJN1,W,FL1,GL1,NF,DF,FL,NG,DG,GL,
     4 QN,KN,KM,I,ZIN,PN,HM,HN,ZT3,ZT4,
     5 S1,S2,S3,S4,FM1,FM2,FN1,FN2,HM1,HM2,
     6 HN1,HN2,A1,A2,A3,A4
C
C
      DATA PI/3.1415926535897932/,PSI/-.1159315156584124488107/
      DATA EPSI/ 1.E-9, 1.E-18, 1.E-30, 1.E-30, 1.E+30, 1.E-10, 1.E-14,
     1     1.E+10, 350.0/
      DATA I/(0.0,1.0)/
C
C**MAKE UP LOCAL VARIABLES
      Z=ZIN
      ZR=REAL(Z)
      ZI=AIMAG(Z)
	MORD=M
	IBM=MORD
	RM=FLOAT(MORD)
	NORD=MORD+1
	IBN=NORD
	RN=FLOAT(NORD)
      LIOM=IOM
      JERR=0
C**JERR=1, Z=0
      IF(ZR .EQ. 0.0 .AND. ZI .EQ. 0.0)  GOTO 5000
C**JERR=8., TYPE B.F. WRONG
      IF(LIOM.NE.1.AND.LIOM.NE.2) GOTO 5070
      N=IRP
C**JERR=2., COORDINATE SYSTEM WRONG
      IF(N .NE. 1 .AND. N .NE. 2) GOTO 5010
      IF(N .EQ. 2) GOTO 130
C*******************************************************************
C**RECTANGULAR COORDINATES
      RHO=CABS(Z)
      THETA=ATAN2(ZI,ZR)
      GOTO 140
C******************************************************************
C**POLAR COORDINATES
  130 PHI=ZR
      CHI=ZI
      CHI=AMOD(CHI,360.0)
C**PUT CHI INTO (-180.0,180.0)
      IF(ABS(CHI).GT.180.0) CHI=CHI-SIGN(360.0,CHI)
      RHO=PHI
      THETA=PI*(CHI/180.)
      ZR=RHO*COS(THETA)
      ZI=RHO*SIN(THETA)
      Z=CMPLX(ZR,ZI)
C*******************************************************************
C**JERR=3., PREVENTS GETTING LOG 0
C**EPSI(3)=1.E-48
  140 IF(RHO .LT. EPSI(3))  GOTO 5020
      ZL=CMPLX(ALOG(RHO)+PSI,THETA)
      IF(LIOM .EQ. 2) GOTO 160
C******************************************************************
C**SIGNS FOR ORDINARY B.F.
      SGN=-1.0
      SGPI=2./PI
      GOTO 170
C******************************************************************
C**SIGNS FOR MODIFIED B.F.
  160 SGN=1.0
      SGPI=1.0
C******************************************************************
  170 OH=.5*Z
      X=OH**2
      Y=1.0/Z
C*****************************************************************
C**WEBER-SCHLAFLI
      IF(RHO .LT. 21.0)  GOTO  180
C**HANKEL ASYMPTOTIC SERIES
      IF(FLOAT(IBN**2)/RHO .LE. 1.95)  GOTO  1000
C**GAUSS CONTINUED FRACTION AND RECURRENCE
  180 IF(RHO .GT. 2.5)  GOTO  600
C
C     SET UP INTIIAL CONDITIONS FOR  M=0  N=1
C
C**RETURN FOR SMALL CABS(Z)<2.5
      ASSIGN 2000 TO JS1
  200 IF(IBM-1) 201,210,220
C*********************************************************************
C**COMMON FACTOR OF J(0) AND I(0)
  201 CM1=1.
C**COMMON FACTOR OF J(1) AND I(1)
      CN1=OH
C**COMMON FACTOR OF INFINITE SERIES FOR Y(0) AND K(0)
      CM2=SGN*.5
C**COMMON FACTOR OF INFINITE SERIES FOR Y(1) AND K(1)
      CN2=SGN*.5*OH
C*******************************************************************
      SRV=0.0
      SRW=1.0
C*******************************************************************
C**COMMON FACTOR OF FINITE SERIES FOR Y(0) AND K(0)
      CM3=0.0
C**COMMON FACTOR OF FINITE SERIES FOR Y(1) AND K(1)
      CN3=SGN*Y
C**SUM OF TERMS OF FINITE SERIES FOR Y(0) AND K(0)
      CM4=0.0
C**SUM OF TERMS OF FINITE SERIES FOR Y(1) AND K(1)
      CN4=1.0
C*****************************************************************
      GOTO 500
C
C     SET UP INITIAL CONDITIONS FOR  M=1  N=2
C
  210 CM1=OH
      CN1=X*.5
      CM2=SGN*.5*OH
      CN2=SGN*.5*CN1
      SRV=1.0
      SRW=1.5
      CM3=SGN*Y
      CN3=SGN*2.*Y**2
      CM4=1.0
      CN4=1.-SGN*X
      GOTO 500
C
C     SET UP INITIAL CONDITIONS FOR  M=2  N=3
C
  220 IF(IBM .GT. 2)  GOTO 300
      CM1=.5*X
      CN1=X*OH/6.
      CM2=SGN*.5*CM1
      CN2=SGN*.5*CN1
      SRV=1.5
      SRW=11./6.
      CM3=SGN*2.*Y**2
      CN3=1.0/(SGN*6.*CN1)
      CM4=1.-SGN*X
      CN4=1.-SGN*.5*X+(.5*X)**2
      GOTO 500
C
C     CODING FOR THE I TH ORDER FOR RHO < 2.5
C
  300 CM1=X*.5
      T3=2.
      SRV=1.5
  310 T3=T3+1.
      T4=1./T3
      CM1=OH*CM1*T4
      T5=CABS(CM1)
C**JERR=4., CONSTANT TERM OF FINITE SERIES TOO LARGE
C**EPSI(5)=1.E+75, EPSI(4)=1.E-75
      IF(T5 .GT. EPSI(5) .OR. T5 .LT. EPSI(4))  GOTO 5030
      SRV=SRV+T4
      IF(INT(T3) .NE. IBM)  GOTO 310
      T4=1./(T3+1.)
      SRW=SRV+T4
      CN1=OH*CM1*T4
      CM3=1.0/(FLOAT(2*IBM)*SGN*CM1)
      CN3=1.0/(FLOAT(2*IBN)*SGN*CN1)
      CM2=SGN*.5*CM1
      CN2=SGN*.5*CN1
C
C     COMPUTE THE FINITE SERIES
C
      TM(1)=1.0
      TN(1)=1.0
      IFR=1
      K=0
  400 K=K+1
	IF ((IFR .EQ. 0) .OR. (IBM .EQ. IFR) .OR. (IBN .EQ. IFR))
     +       TYPE 10 ,IFR,IBM,IBN
 10	FORMAT (' WARNING (BESSEL) -- IFR, IBM, IBN',3I10)
      TM(K+1)=-SGN*TM(K)*X/FLOAT(IFR*(IBM-IFR))
      TN(K+1)=-SGN*TN(K)*X/FLOAT(IFR*(IBN-IFR))
      IFR=IFR+1
      T2=CABS(TN(K+1))
C**EPSI(2)=1.E-18
      IF(T2 .GE. EPSI(2) .AND. K .LT. 100 .AND. IFR .NE. IBM)  GOTO 400
      IF(T2 .GE. EPSI(2) .AND. K .EQ. 100 .AND. IFR .NE. IBM)  STOP 777
      CN4=TN(K+1)+TN(K)
      CM4=TM(K)
C**SUM THE SERIES TERMS IN REVERSE ORDER
  440 K=K-1
      CN4=CN4+TN(K)
      CM4=CM4+TM(K)
      IF(K .GT. 1)  GOTO 440
C
C     COMPUTE THE INFINITE SERIES
C
  500 TM(1)=1.0
      TN(1)=1.0
      TV(1)=SRV
      TW(1)=SRW
      K=0
      IFR=0
      T1=FLOAT(IBN)
      T3=SRW
      T4=0.0
C******************************************************************
C**BEGIN.. CALCULATE TERMS IN SERIES UNTIL IT CONVERGES
  510 K=K+1
      IFR=IFR+1
      T1=T1+1.0
      T2=T3
      T3=T2+1.0/T1
      T4=T4+1.0/FLOAT(IFR)
      P=T4+T2
      Q=T4+T3
C**J(M) OR I(M)
      TM(K+1)=SGN*TM(K)*X/FLOAT(IFR*(IBM+IFR))
C**Y(M) OR K(M)
      TV(K+1)=P*TM(K+1)
C**J(N) OR I(N)
      TN(K+1)=SGN*TN(K)*X/FLOAT(IFR*(IBN+IFR))
C**Y(N) OR K(N)
      TW(K+1)=Q*TN(K+1)
      T5=CABS(TW(K+1))
C**OUT OF LOOP
C**EPSI(2)=1.E-18
      IF(T5 .GE. EPSI(2) .AND. K .LT. 100)  GOTO 510
      IF(T5 .GE. EPSI(2) .AND. K .EQ. 100) STOP 776
C***********************************************************
C**J(M) OR I(M)
      ST=TM(K+1)
C**J(N) OR I(N)
      SU=TN(K+1)
C**Y(M) OR K(M)
      SV=TV(K+1)
C**Y(N) OR K(N)
      SW=TW(K+1)
C**SUM THE SERIES TERMS IN REVERSE ORDER
  540 ST=ST+TM(K)
      SU=SU+TN(K)
      SV=SV+TV(K)
      SW=SW+TW(K)
      K=K-1
      IF(K .GT. 0) GOTO 540
C**RESULTS STORED IN OUTPUT ARRAYS
      JIM=CM1*ST
      JIN=CN1*SU
      SGN1=1.0
      SGN2=1.0
C**ORDINARY B.F.
      IF(LIOM .EQ. 1)  GOTO 560
C**MODIFIED B.F. DIFFER IN SIGNS OF EVEN TERMS
C**M EVEN, N ODD, SGN1=1.0
C**M ODD, N EVEN
      IF(MOD(MORD,2).EQ.0) SGN1=-1.0
      SGN2=-SGN1
C**SUM THE LOGARITHMIC TERM, THE FINITE TERM, AND THE
C**THE INFINITE SERIES TERM.  THEN MULTIPLY BY THEIR
C**COMMON FACTOR.
C**FIRST, DO Y(M) OR K(M)
  560 YKM=SGPI*(SGN1*JIM*ZL+CM3*CM4+SGN2*CM2*SV)
C**THEN DO Y(N) OR K(N)
      YKN=SGPI*(SGN2*JIN*ZL+CN3*CN4+SGN1*CN2*SW)
      GOTO  JS1,(2000,630)
C
C     COMPUTATION FOR Z > 2.5 BY USE OF RECURSION FORMULAS
C
C**RETURN TO RECURSION AFTER USING SERIES TO CALCULATE
C**STARTING VALUE FOR RECURRENCE PROCEDURES.
  600 ASSIGN 630 TO JS1
      TX=RHO*RHO/4.0
      T1=1.0
      IFR=0
      IFN=NORD
C**INCREASE ORDER UNTIL T1 < 1.E-10
  610 IFR=IFR+1
      IFN=IFN+1
      T1=T1*TX/FLOAT(IFR*IFN)
C**EPSI(6)=1.E-10
      IF(T1 .GE. EPSI(6))  GOTO 610
      IBM=IFN
      IBN=IFN+1
C**GO COMPUTE B.F. OF ORDER iFN AND iFN+1 USING SERIES.
      GOTO 200
C**RETURN FROM SERIES.  USE B.F. OF HIGH ORDER TO
C**START DOWNWARD RECURSION.
  630 JHN1=JIN
      JHM1=JIM
C**J(M-1)=(2M/Z)*J(M)-J(N)
      JHM=FLOAT(2*IBM)*Y*JHM1+SGN*JHN1
      IBM=IBM-1
      IF(IBM.LE.MORD) GOTO 650
C**J(N)=J(M)=J(N-1)
  640 JHN1=JHM1
C**J(M)=J(M-1)
      JHM1=JHM
      JHM=FLOAT(2*IBM)*Y*JHM1+SGN*JHN1
C**DECREASE ORDER TO COMPUTE J(M-2) = ((2*(M-1))/Z)*J(M-1)-J(N-1)
C**UNTIL IBM = MORD.
      IBM=IBM-1
C**FINISHED RECURSION
      IF(IBM .NE. MORD)  GOTO 640
C**J OR I COMPUTED BY RECURSION ARE STORED IN OUTPUT ARRAYS
  650 JIM=JHM
      JIN=JHM1
C**SAVE VALUES OF J(M) AND J(N) COMPUTED BY DOWNWARD RECURSION.
      SJM1=JIM
      SJN1=JIN
C
C     COMPUTE Y AND K BY USING CONTINUED FRACTIONS OF GAUSS
C
      SGN1=1.0
      IF(LIOM .EQ. 2)  GOTO 700
C**ORDINARY B.F.
      SGN3=1.0
      IF(ZI .GE. 0.0)  GOTO 730
      SGN1=-1.0
      SGN3=-1.0
C**1/2Z., ROTATED BY SGN1 TO RIGHT HALF-PLANE IF NECESSARY.
  730 W=.5*SGN1*Y*I
      GO TO 740
C**MODIFIED B.F.
C**Z IN RIGHT HALF-PLANE
  700 IF(ZR .GE. 0.0)  GOTO 710
C**MODIFIED B.F.., LEFT HALF-PLANE
      SGN1=-1.0
C**QUAD II
      SGN3=-1.0
C**QUAD III
      IF(ZI .LT. 0.0) SGN3=1.0
C**1/2Z., ROTATED BY SGN1 TO RIGHT HALF-PLANE IF NECESSARY.
  710 W=SGN1*.5*Y
  740 AA=.5+RN
      BB=.5-RN
      CLL=50.0
C**M ODD, N EVEN
      SGN1=1.0
C**M EVEN, N ODD
      IF(MOD(NORD,2).NE.0) SGN1=-1.0
      SGN2=-SGN1
      FL=0.0
      GL=0.0
C**BEGIN USING CONTINUED FRACTION FOR Y OR K
  760 FL1=FL
      GL1=GL
      BL=BB+CLL
      BL1=BL+1.0
      ALL=AA+CLL-1.0
C****************************************************************
C**H(L)(A,B.,V)
      NF=1.0+BL*W*FL1
      DF=NF+ALL*W
      FL=NF/DF
C***************************************************************
C**G(L)(A,B.,V)
      NG=1.0+BL1*W*GL1
      DG=NG+ALL*W
      GL=NG/DG
C*************************************************************
      CLL=CLL-1.0
      IF(CLL .GE. .5)  GOTO 760
      QN=FL*(1.0+(BB+1.0)*W*GL)
C************************************************************
C**ORDINARY B.F.
      IF(LIOM .EQ. 2)  GOTO 780
C**ORDINARY B.F.
C**ANALYTIC CONTINUATION TO FIND CORRECT VALUE FOR Y
      PN=I*SGN3*QN
      HN=4.0*W/(PI*(PN*JIN-JIM))
      HM=HN*PN
C*********************************************************
C**Y STORED IN OUTPUT ARRAYS
      YKM=SGN3*I*(JIM-HM)
      YKN=SGN3*I*(JIN-HN)
C********************************************************
C**RETURN FROM SUBROUTINE
      GOTO  2000
C**MODIFIED B.F.
C**Z IN RIGHT-HALF PLANE
  780 IF(ZR .GE. 0.0)  GOTO 790
C**-I(N) WHEN N IS ODD
      SJN1=SGN1*SJN1
C**I(M) WHEN M IS EVEN
      SJM1=SGN2*SJM1
C**Q(N)*I(N)+I(M)=Q(M+1)*I(M+1)+I(M)
  790 KN=2.0*W/(QN*SJN1+SJM1)
C**K(M)=K(N)*Q(N)=K(N-1)
      KM=QN*KN
C*************************************************************
      IF(ZR .GE. 0.0) GO TO 810
C**ANALYTIC CONTINUATION USED TO FIND CORRECT VALUE FOR K
      T1=SGN3*PI
      KN=SGN1*KN+I*T1*SJN1
      KM=SGN2*KM+I*T1*SJM1
C************************************************************
C**RESULTS STORED IN OUTPUT ARRAYS.
  810 YKM=KM
      YKN=KN
C**RETURN FROM SUBROUTINE
      GOTO 2000
C
C     COMPUTE BESSEL FUNCTIONS USING HANKEL ASYMPTOTIC SERIES
C
 1000 SGN1=1.0
      T=-I
      ZETA=.5*THETA
C**RIGHT HALF-PLANE
      IF(ZR .GE. 0.0)  GOTO 1010
C**ROTATE Z TO RIGHT HALF-PLANE.
      SGN1=-1.0
      T=I
C**ROTATE -180 DEGREES FROM QUAD II TO QUAD IV
      ZETA=.5*(THETA-PI)
C**ROTATE 180 DEGREES FROM QUAD III TO QUAD I
      IF(ZI .LT. 0.0) ZETA=.5*(THETA+PI)
C**PUTS Z IN RIGHT HALF-PLANE
 1010 RED=SGN1*ZR
      CMD=SGN1*ZI
C**ORDINARY B.F.
C**+-I/(8*Z)
      IF(LIOM .EQ. 1) W=T*Y*0.125
C**MODIFIED B.B.
C**+-1/(8*Z)
      IF(LIOM .EQ.2) W=SGN1*Y*0.125
      K=2
      TC1=1.0
      TC2=1.0
C**4*M**2
      RFM2=4.0*RM*RM
C**4*N**2
      RFN2=4.0*RN*RN
      SGN=-1.0
      TM(1)=1.0
      TN(1)=1.0
      TV(1)=1.0
      TW(1)=1.0
C**(4*M**2-1)*(-I/(8*Z))
      ZT3=(RFM2-1.0)*W
C**(4*N**2-1)*(I/(8*Z))
      ZT4=(RFN2-1.0)*W
      TM(2)=-ZT3
      TN(2)=ZT3
      TV(2)=-ZT4
      TW(2)=ZT4
      T5=CABS(ZT4)
 1050 K=K+1
      TC1=TC1+1.0
      TC2=TC2+2.0
      SGN=-SGN
C**M-TH TERM OF SERIES P(M) +- I*Q(M) OR P(M) +- Q(M)
      ZT3=((RFM2-TC2**2)/TC1)*ZT3*W
C**N-TH TERM OF SERIES P(N) +- I*Q(N) OR P(N) +- Q(N)
      ZT4=((RFN2-TC2**2)/TC1)*ZT4*W
      TM(K)=SGN*ZT3
      TN(K)=ZT3
      TV(K)=SGN*ZT4
      TW(K)=ZT4
C**EPSI(2)=1.E-18
      IF(CABS(ZT3) .GE. EPSI(2) .AND. K .LT. 100
     1   .AND. T5 .GE. CABS(ZT4)) GOTO 1050
      IF(CABS(ZT3) .GE. EPSI(2) .AND. K .EQ. 100
     1   .AND. T5 .GE. CABS(ZT4)) STOP 775
      IF(CABS(ZT3) .GE. EPSI(2) .AND. T5 .LT. CABS(ZT4)) K=K-1
      S1=TM(K)
      S2=TN(K)
      S3=TV(K)
      S4=TW(K)
C**SUM THE SERIES TERMS IN REVERSE ORDER
 1080 K=K-1
C**P(M)+I*Q(M) FOR J(M) OR P(M)+Q(M) FOR I(M)
      S1=S1+TM(K)
C**P(M)-I*Q(M) FOR Y(M) OR P(M)-Q(M) FOR K(M)
      S2=S2+TN(K)
C**P(N)+I*Q(N) FOR J(N) OR P(N)+Q(N) FOR I(N)
      S3=S3+TV(K)
C**P(N)-I*Q(N) FOR Y(N) OR P(N)-Q(N) FOR K(N)
      S4=S4+TW(K)
      IF(K .NE. 1)  GOTO  1080
      IF(LIOM.EQ.2) GO TO 1200
C********************************************************
C**ORDINARY B.F.
      C1=1.0/SQRT(.5*PI*RHO)
      C2=.25*PI
      C3=.5*PI*RM
      C4=.5*PI*RN
C**EPSI(9)=350.0
      IF(ABS(CMD) .GT. EPSI(9))  GOTO 5040
      C5=C1*EXP(-CMD)
      C6=C1*EXP(CMD)
C**EPSI(8)=1.0E+10
      IF(ABS(RED) .GT. EPSI(8))  GOTO 5050
C**+- ZR - THETA/2 - PI/4 - N*M/2
      ALPH1=RED-ZETA-C2-C3
      ALPH2=RED+ZETA-C2-C3
      ALPH3=RED-ZETA-C2-C4
      ALPH4=RED+ZETA-C2-C4
C**H(N)(1)(Z)
      FM1=C5*CMPLX(COS(ALPH1),SIN(ALPH1))*S1
C**H(N)(2)(Z)
      FM2=C6*CMPLX(COS(ALPH2),-SIN(ALPH2))*S2
C**H(N+1)(1)(Z)
      FN1=C5*CMPLX(COS(ALPH3),SIN(ALPH3))*S3
C**H(N+1)(2)(Z)
      FN2=C6*CMPLX(COS(ALPH4),-SIN(ALPH4))*S4
      IF(ZR .LT. 0.0)  GOTO  1115
C**Z LIES IN RIGHT HALF-PLANE
C**J(M)
      HM1=FM1
C**Y(M)
      HM2=FM2
C**J(N)
      HN1=FN1
C**Y(N)
      HN2=FN2
      GOTO  1140
C**CORRECT HANKEL FUNCTIONS IF Z WAS GIVEN IN THE
C**LEFT HALF-PLANE
C**M EVEN, N ODD
 1115 SGN1=1.0
C**M ODD, N EVEN
      IF(MOD(MORD,2) .NE. 0) SGN1=-1.0
      SGN2=-SGN1
      IF(ZI .LT. 0.0)  GOTO  1130
C**IV --> II
      HM1=SGN2*FM2
      HM2=SGN1*(FM1+2.0*FM2)
      HN1=SGN1*FN2
      HN2=SGN2*(FN1+2.0*FN2)
      GOTO  1140
C**I --> III
 1130 HM1=SGN1*(2.0*FM1+FM2)
      HM2=SGN2*FM1
      HN1=SGN2*(2.0*FN1+FN2)
      HN2=SGN1*FN1
C**OUTPUT ARRAYS FOR ORDINARY B.F.
 1140 JIM=.5*(HM1+HM2)
      JIN=.5*(HN1+HN2)
      YKM=.5*I*(HM2-HM1)
      YKN=.5*I*(HN2-HN1)
C**RETURN
      GOTO  2000
C********************************************************
C**MODIFIED B.F.
 1200 C1=1.0/SQRT(2.0*PI)
      C2=1.0/SQRT(RHO)
      C3=SQRT(.5*PI)
C**EPSI(9)=350.0
      IF(ABS(RED) .GT. EPSI(9))  GOTO 5040
      C4=EXP(-RED)
      C5=C1*C2*EXP(RED)
      C6=C1*C2*C4
      C7=C3*C2*C4
C**EPSI(8)=1.0E+10
      IF(ABS(CMD) .GT. EPSI(8)) GOTO 5050
      ALPH1=CMD-ZETA
      A1=CMPLX(COS(ALPH1),SIN(ALPH1))
      SGN1=1.0
      IF(ZR .LE. 0.0) SGN1=-1.0
      IF(ZI .LE. 0.0) SGN1=-SGN1
      ALPH2=-CMD-ZETA+SGN1*(RM+.5)*PI
      A2=CMPLX(COS(ALPH2),SIN(ALPH2))
      ALPH3=-CMD-ZETA+SGN1*(RN+.5)*PI
      A3=CMPLX(COS(ALPH3),SIN(ALPH3))
      ALPH4=-ZETA-CMD
      A4=CMPLX(COS(ALPH4),SIN(ALPH4))
C**I(M)
      FM1=C5*A1*S1+C6*A2*S2
C**I(N)
      FN1=C5*A1*S3+C6*A3*S4
C**K(M)
      FM2=C7*A4*S2
C**K(N)
      FN2=C7*A4*S4
      IF(ZR .LT. 0.0)  GOTO  1220
C**OUTPUT ARRAYS FOR Z IN RIGHT HALF-PLANE
      JIM=FM1
      JIN=FN1
      YKM=FM2
      YKN=FN2
C**RETURN
      GOTO  2000
C**OUTPUT ARRAYS FOR Z IN LEFT HALF-PLANE
C**M EVEN, N ODD
 1220 SGN1=1.0
C**M ODD, N EVEN
      IF(MOD(MORD,2) .NE. 0) SGN1=-1.0
      SGN2=-SGN1
C**QUAD II
      T=I
C**QUAD III
      IF(ZI .LT. 0.0) T=-I
      JIM=SGN1*FM1
      JIN=SGN2*FN1
      YKM=SGN1*(FM2-T*PI*JIM)
      YKN=SGN2*(FN2-T*PI*JIN)
C**RETURN
      GOTO  2000
C********************************************************
C
C     ERROR PRINT OUTS
C
 5000 JERR=1
      GOTO 5090
 5001 WRITE(7,5002)
 5002 FORMAT(// 49H CAN NOT COMPUTE THE BESSEL FUNCTION IF Z IS ZERO)
      WRITE(7,5003)
 5003 FORMAT(// 47H J 0 EQUAL 1  -  ALL OTHER ORDERS OF J ARE ZERO)
      WRITE(7,5004)
 5004 FORMAT(38H0ALL ORDERS OF Y ARE EQUAL TO INFINITY)
      GO TO 5100
C************************************************************
 5010  JERR=2
      GOTO 5090
 5011 WRITE(7,5012) OPT2
 5012 FORMAT(/ 30H OPT2 IS NOT 1 OR 2     OPT2 =,E12.4)
      GOTO 5100
C**************************************************************
 5020 JERR=3
      GOTO 5090
 5021 WRITE(7,5022) RHO
 5022 FORMAT(// 29H RHO IS OUTSIDE RANGE   RHO =,E12.4)
      GO TO 5100
C*************************************************************
 5030 JERR=4
      GOTO 5090
 5031 WRITE(7,5032)
 5032 FORMAT(// 43H CONSTANT TERM OF FINITE SERIES WILL EXCEED,
     123H NUMBER SIZE OF MACHINE)
      WRITE(7,5033) OM,RN,CMR1,CMI1
 5033 FORMAT(4HOM =,F12.4, 5H  N =,E12.4, 8H  CMR1 =,E12.4,
     1 8H  CMI1 =, E12.4)
      WRITE(7,5034) PHI,CHI
 5034 FORMAT(6H0PHI =,E15.8, 7H  CHI =,E15.8)
      GOTO 5100
C***************************************************************
 5040 JERR=5
      GOTO 5090
 5041 WRITE(7,5042)
 5042 FORMAT(/ 52H ERROR IN ASYMPTOTIC SECTION - ARGUMENT FOR EXP TOO ,
     1 5HLARGE)
      WRITE(7,5043) RED,CMD
 5043 FORMAT(1H0,5HRED =,E15.8,4X,5HCMD =,E15.8)
      GOTO 5100
C*****************************************************************(
 5050 JERR=6
      GOTO 5090
 5051 WRITE(7,5052)
 5052 FORMAT(/ 52H ARGUMENT FOR SIN AND COS IN ASYMPTOTIC SECTION TOO ,
     1 5HLARGE)
      WRITE(7,5053) ZETA
 5053 FORMAT(1H0,6HZETA =,E15.8)
      GOTO 5100
C****************************************************************
 5060 JERR=7
      GOTO 5090
 5061 WRITE(7,5062)
 5062 FORMAT(55H SUBROUTINE CALCULATES INTEGRAL ORDER ONLY- CHECK INPUT)
      GOTO 5100
C**********************************************************************
 5070 JERR=8
      GOTO 5090
 5071 WRITE(7,5072)
 5072 FORMAT(33H OPT1 IS NOT 1 OR 2 - CHECK INPUT)
      GOTO 5100
C********************************************************************
 5090 WRITE(7,5091)
 5091 FORMAT(// 40H RUN ERROR IN BESSEL FUNCTION SUBROUTINE)
      WRITE(7,5092) PHI,CHI,ORD,OPT1,OPT2
 5092 FORMAT(1H0,5HPHI =,F15.8,4X,5HCHI =,F15.8,4X,5HORD =,F6.1,4X,
     1 6HOPT1 =,F6.1,4X,6HOPT2 =,F6.1)
      GOTO (5001,5011,5021,5031,5041,5051,5061,5071), JERR
 5100 WRITE(7,5101)
 5101 FORMAT(1H )
C
 2000 LERR=JERR
      GJIM=JIM
      GJIN=JIN
      GYKM=YKM
      GYKN=YKN
      RETURN
      END


      SUBROUTINE FLTRAN (A,B,C, MAT)

C  Given a set of attitude numbers for a plane, FLTRAN returns a
C  4 X 4 transformation matrix which rotates the plane so as to be
C  parallel to the z=0 plane.  This is useful for visualizing a
C  planar 3D primitive.

      REAL     A,B,C, MAT(4,4), ZZ,UU, VECL, SATAN2

      ZZ = 0.0
      UU = 1.0

      CALL EBLTM3 (ZZ,ZZ,ZZ, ZZ,ZZ,ZZ,
     1     -SATAN2(-B,C), -ASIN(A/VECL(A,B,C)),ZZ, UU,UU,UU, MAT)

      END