*     fortran version of *dgpfa3* -
*     radix-3 section of self-sorting, in-place
*        generalized PFA
*
*-------------------------------------------------------------------
*
      subroutine dgpfa3f(a,b,trigs,inc,jump,n,mm,lot,isign)
      double precision a(*), b(*), trigs(*)
      integer inc, jump, n, mm, lot, isign
      double precision s, c1, t1, t2, t3, u1, u2, u3, co1, co2
      double precision si1, si2, aja, ajb, ajc, bjb, bjc, bja, ajd, bjd
      double precision aje, ajf, ajh, bje, bjf, bjh, aji, ajg, bji, bjg
      data sin60/0.866025403784437d+0/
      data lvr/128/

*
*     ***************************************************************
*     *                                                             *
*     *  N.B. LVR = LENGTH OF VECTOR REGISTERS, SET TO 128 FOR C90. *
*     *  RESET TO 64 FOR OTHER CRAY MACHINES, OR TO ANY LARGE VALUE *
*     *  (GREATER THAN OR EQUAL TO LOT) FOR A SCALAR COMPUTER.      *
*     *                                                             *
*     ***************************************************************
*
      n3 = 3**mm
      inq = n/n3
      jstepx = (n3-n) * inc
      ninc = n * inc
      ink = inc * inq
      mu = mod(inq,3)
      if (isign.eq.-1) mu = 3-mu
      m = mm
      mh = (m+1)/2
      s = dfloat(isign)
      c1 = sin60
      if (mu.eq.2) c1 = -c1
*
      nblox = 1 + (lot-1)/lvr
      left = lot
      s = dfloat(isign)
      istart = 1
*
*  loop on blocks of lvr transforms
*  --------------------------------
      do 500 nb = 1 , nblox
*
      if (left.le.lvr) then
         nvex = left
      else if (left.lt.(2*lvr)) then
         nvex = left/2
         nvex = nvex + mod(nvex,2)
      else
         nvex = lvr
      endif
      left = left - nvex
*
      la = 1
*
*  loop on type I radix-3 passes
*  -----------------------------
      do 160 ipass = 1 , mh
      jstep = (n*inc) / (3*la)
      jstepl = jstep - ninc
*
*  k = 0 loop (no twiddle factors)
*  -------------------------------
      do 120 jjj = 0 , (n-1)*inc , 3*jstep
      ja = istart + jjj
*
*  "transverse" loop
*  -----------------
      do 115 nu = 1 , inq
      jb = ja + jstepl
      if (jb.lt.istart) jb = jb + ninc
      jc = jb + jstepl
      if (jc.lt.istart) jc = jc + ninc
      j = 0
*
*  loop across transforms
*  ----------------------
cdir$ ivdep, shortloop
      do 110 l = 1 , nvex
      ajb = a(jb+j)
      ajc = a(jc+j)
      t1 = ajb + ajc
      aja = a(ja+j)
      t2 = aja - 0.5 * t1
      t3 = c1 * ( ajb - ajc )
      bjb = b(jb+j)
      bjc = b(jc+j)
      u1 = bjb + bjc
      bja = b(ja+j)
      u2 = bja - 0.5 * u1
      u3 = c1 * ( bjb - bjc )
      a(ja+j) = aja + t1
      b(ja+j) = bja + u1
      a(jb+j) = t2 - u3
      b(jb+j) = u2 + t3
      a(jc+j) = t2 + u3
      b(jc+j) = u2 - t3
      j = j + jump
  110 continue
      ja = ja + jstepx
      if (ja.lt.istart) ja = ja + ninc
  115 continue
  120 continue
*
*  finished if n3 = 3
*  ------------------
      if (n3.eq.3) go to 490
      kk = 2 * la
*
*  loop on nonzero k
*  -----------------
      do 150 k = ink , jstep-ink , ink
      co1 = trigs(kk+1)
      si1 = s*trigs(kk+2)
      co2 = trigs(2*kk+1)
      si2 = s*trigs(2*kk+2)
*
*  loop along transform
*  --------------------
      do 140 jjj = k , (n-1)*inc , 3*jstep
      ja = istart + jjj
*
*  "transverse" loop
*  -----------------
      do 135 nu = 1 , inq
      jb = ja + jstepl
      if (jb.lt.istart) jb = jb + ninc
      jc = jb + jstepl
      if (jc.lt.istart) jc = jc + ninc
      j = 0
*
*  loop across transforms
*  ----------------------
cdir$ ivdep,shortloop
      do 130 l = 1 , nvex
      ajb = a(jb+j)
      ajc = a(jc+j)
      t1 = ajb + ajc
      aja = a(ja+j)
      t2 = aja - 0.5 * t1
      t3 = c1 * ( ajb - ajc )
      bjb = b(jb+j)
      bjc = b(jc+j)
      u1 = bjb + bjc
      bja = b(ja+j)
      u2 = bja - 0.5 * u1
      u3 = c1 * ( bjb - bjc )
      a(ja+j) = aja + t1
      b(ja+j) = bja + u1
      a(jb+j) = co1*(t2-u3) - si1*(u2+t3)
      b(jb+j) = si1*(t2-u3) + co1*(u2+t3)
      a(jc+j) = co2*(t2+u3) - si2*(u2-t3)
      b(jc+j) = si2*(t2+u3) + co2*(u2-t3)
      j = j + jump
  130 continue
*-----( end of loop across transforms )
      ja = ja + jstepx
      if (ja.lt.istart) ja = ja + ninc
  135 continue
  140 continue
*-----( end of loop along transforms )
      kk = kk + 2*la
  150 continue
*-----( end of loop on nonzero k )
      la = 3*la
  160 continue
*-----( end of loop on type I radix-3 passes)
*
*  loop on type II radix-3 passes
*  ------------------------------
  400 continue
*
      do 480 ipass = mh+1 , m
      jstep = (n*inc) / (3*la)
      jstepl = jstep - ninc
      laincl = la*ink - ninc
*
*  k=0 loop (no twiddle factors)
*  -----------------------------
      do 430 ll = 0 , (la-1)*ink , 3*jstep
*
      do 420 jjj = ll , (n-1)*inc , 3*la*ink
      ja = istart + jjj
*
*  "transverse" loop
*  -----------------
      do 415 nu = 1 , inq
      jb = ja + jstepl
      if (jb.lt.istart) jb = jb + ninc
      jc = jb + jstepl
      if (jc.lt.istart) jc = jc + ninc
      jd = ja + laincl
      if (jd.lt.istart) jd = jd + ninc
      je = jd + jstepl
      if (je.lt.istart) je = je + ninc
      jf = je + jstepl
      if (jf.lt.istart) jf = jf + ninc
      jg = jd + laincl
      if (jg.lt.istart) jg = jg + ninc
      jh = jg + jstepl
      if (jh.lt.istart) jh = jh + ninc
      ji = jh + jstepl
      if (ji.lt.istart) ji = ji + ninc
      j = 0
*
*  loop across transforms
*  ----------------------
cdir$ ivdep, shortloop
      do 410 l = 1 , nvex
      ajb = a(jb+j)
      ajc = a(jc+j)
      t1 = ajb + ajc
      aja = a(ja+j)
      t2 = aja - 0.5 * t1
      t3 = c1 * ( ajb - ajc )
      ajd = a(jd+j)
      ajb =  ajd
      bjb = b(jb+j)
      bjc = b(jc+j)
      u1 = bjb + bjc
      bja = b(ja+j)
      u2 = bja - 0.5 * u1
      u3 = c1 * ( bjb - bjc )
      bjd = b(jd+j)
      bjb =  bjd
      a(ja+j) = aja + t1
      b(ja+j) = bja + u1
      a(jd+j) = t2 - u3
      b(jd+j) = u2 + t3
      ajc =  t2 + u3
      bjc =  u2 - t3
*----------------------
      aje = a(je+j)
      ajf = a(jf+j)
      t1 = aje + ajf
      t2 = ajb - 0.5 * t1
      t3 = c1 * ( aje - ajf )
      ajh = a(jh+j)
      ajf =  ajh
      bje = b(je+j)
      bjf = b(jf+j)
      u1 = bje + bjf
      u2 = bjb - 0.5 * u1
      u3 = c1 * ( bje - bjf )
      bjh = b(jh+j)
      bjf =  bjh
      a(jb+j) = ajb + t1
      b(jb+j) = bjb + u1
      a(je+j) = t2 - u3
      b(je+j) = u2 + t3
      a(jh+j) = t2 + u3
      b(jh+j) = u2 - t3
*----------------------
      aji = a(ji+j)
      t1 = ajf + aji
      ajg = a(jg+j)
      t2 = ajg - 0.5 * t1
      t3 = c1 * ( ajf - aji )
      t1 = ajg + t1
      a(jg+j) = ajc
      bji = b(ji+j)
      u1 = bjf + bji
      bjg = b(jg+j)
      u2 = bjg - 0.5 * u1
      u3 = c1 * ( bjf - bji )
      u1 = bjg + u1
      b(jg+j) = bjc
      a(jc+j) = t1
      b(jc+j) = u1
      a(jf+j) = t2 - u3
      b(jf+j) = u2 + t3
      a(ji+j) = t2 + u3
      b(ji+j) = u2 - t3
      j = j + jump
  410 continue
*-----( end of loop across transforms )
      ja = ja + jstepx
      if (ja.lt.istart) ja = ja + ninc
  415 continue
  420 continue
  430 continue
*-----( end of double loop for k=0 )
*
*  finished if last pass
*  ---------------------
      if (ipass.eq.m) go to 490
*
      kk = 2*la
*
*     loop on nonzero k
*     -----------------
      do 470 k = ink , jstep-ink , ink
      co1 = trigs(kk+1)
      si1 = s*trigs(kk+2)
      co2 = trigs(2*kk+1)
      si2 = s*trigs(2*kk+2)
*
*  double loop along first transform in block
*  ------------------------------------------
      do 460 ll = k , (la-1)*ink , 3*jstep
*
      do 450 jjj = ll , (n-1)*inc , 3*la*ink
      ja = istart + jjj
*
*  "transverse" loop
*  -----------------
      do 445 nu = 1 , inq
      jb = ja + jstepl
      if (jb.lt.istart) jb = jb + ninc
      jc = jb + jstepl
      if (jc.lt.istart) jc = jc + ninc
      jd = ja + laincl
      if (jd.lt.istart) jd = jd + ninc
      je = jd + jstepl
      if (je.lt.istart) je = je + ninc
      jf = je + jstepl
      if (jf.lt.istart) jf = jf + ninc
      jg = jd + laincl
      if (jg.lt.istart) jg = jg + ninc
      jh = jg + jstepl
      if (jh.lt.istart) jh = jh + ninc
      ji = jh + jstepl
      if (ji.lt.istart) ji = ji + ninc
      j = 0
*
*  loop across transforms
*  ----------------------
cdir$ ivdep, shortloop
      do 440 l = 1 , nvex
      ajb = a(jb+j)
      ajc = a(jc+j)
      t1 = ajb + ajc
      aja = a(ja+j)
      t2 = aja - 0.5 * t1
      t3 = c1 * ( ajb - ajc )
      ajd = a(jd+j)
      ajb =  ajd
      bjb = b(jb+j)
      bjc = b(jc+j)
      u1 = bjb + bjc
      bja = b(ja+j)
      u2 = bja - 0.5 * u1
      u3 = c1 * ( bjb - bjc )
      bjd = b(jd+j)
      bjb =  bjd
      a(ja+j) = aja + t1
      b(ja+j) = bja + u1
      a(jd+j) = co1*(t2-u3) - si1*(u2+t3)
      b(jd+j) = si1*(t2-u3) + co1*(u2+t3)
      ajc =  co2*(t2+u3) - si2*(u2-t3)
      bjc =  si2*(t2+u3) + co2*(u2-t3)
*----------------------
      aje = a(je+j)
      ajf = a(jf+j)
      t1 = aje + ajf
      t2 = ajb - 0.5 * t1
      t3 = c1 * ( aje - ajf )
      ajh = a(jh+j)
      ajf =  ajh
      bje = b(je+j)
      bjf = b(jf+j)
      u1 = bje + bjf
      u2 = bjb - 0.5 * u1
      u3 = c1 * ( bje - bjf )
      bjh = b(jh+j)
      bjf =  bjh
      a(jb+j) = ajb + t1
      b(jb+j) = bjb + u1
      a(je+j) = co1*(t2-u3) - si1*(u2+t3)
      b(je+j) = si1*(t2-u3) + co1*(u2+t3)
      a(jh+j) = co2*(t2+u3) - si2*(u2-t3)
      b(jh+j) = si2*(t2+u3) + co2*(u2-t3)
*----------------------
      aji = a(ji+j)
      t1 = ajf + aji
      ajg = a(jg+j)
      t2 = ajg - 0.5 * t1
      t3 = c1 * ( ajf - aji )
      t1 = ajg + t1
      a(jg+j) = ajc
      bji = b(ji+j)
      u1 = bjf + bji
      bjg = b(jg+j)
      u2 = bjg - 0.5 * u1
      u3 = c1 * ( bjf - bji )
      u1 = bjg + u1
      b(jg+j) = bjc
      a(jc+j) = t1
      b(jc+j) = u1
      a(jf+j) = co1*(t2-u3) - si1*(u2+t3)
      b(jf+j) = si1*(t2-u3) + co1*(u2+t3)
      a(ji+j) = co2*(t2+u3) - si2*(u2-t3)
      b(ji+j) = si2*(t2+u3) + co2*(u2-t3)
      j = j + jump
  440 continue
*-----(end of loop across transforms)
      ja = ja + jstepx
      if (ja.lt.istart) ja = ja + ninc
  445 continue
  450 continue
  460 continue
*-----( end of double loop for this k )
      kk = kk + 2*la
  470 continue
*-----( end of loop over values of k )
      la = 3*la
  480 continue
*-----( end of loop on type II radix-3 passes )
*-----( nvex transforms completed)
  490 continue
      istart = istart + nvex * jump
  500 continue
*-----( end of loop on blocks of transforms )
*
      return
      end


      subroutine jacobi(a,n,np,d,v,nrot)
C-----------------------------------------------------------------------
C     Subroutine used to find the eigenvalues and eigenvectors of a
C     SYMMETRIC matrix, a, with physical dimension, np, and logical
C     dimension, n.
C     Eigenvalues stored in d.
C     Normalised eigenvectors formed and stored in v.
C     nrot gives the total number of steps.
C     Taken from Numerical Recipes Online book: www.nr.com.
C     Slightly modified to deal with double precision reals.
C-----------------------------------------------------------------------
      integer n,np,nrot,nmax
      real*8 a(np,np),d(np),v(np,np)
      parameter (nmax=600)
      integer i,ip,iq,j
      real*8 c,g,h,s,sm,t,tau,theta,tresh,b(nmax),z(nmax)
      do ip=1,n
         do iq=1,n
            v(ip,iq)=0.d0
         enddo
         v(ip,ip)=1.d0
      enddo
      do ip=1,n
         b(ip)=a(ip,ip)
         d(ip)=b(ip)
         z(ip)=0.d0
      enddo
      nrot=0
      do i=1,50
         sm=0.d0
         do ip=1,n-1
            do iq=ip+1,n
               sm=sm+abs(a(ip,iq))
            enddo
         enddo
         if(sm.eq.0.d0)return
         if(i.lt.4)then
            tresh=0.2d0*sm/(dble(n))**2
         else
            tresh=0.d0
         endif
         do ip=1,n-1
            do iq=ip+1,n
               g=100.d0*abs(a(ip,iq))
               if((i.gt.4).and.(abs(d(ip))+g.eq.abs(d(ip)))
     .            .and.(abs(d(iq))+g.eq.abs(d(iq))))then
                  a(ip,iq)=0.d0
               elseif(abs(a(ip,iq)).gt.tresh)then
                  h=d(iq)-d(ip)
                  if(abs(h)+g.eq.abs(h))then
                     t=a(ip,iq)/h
                  else
                     theta=0.5d0*h/a(ip,iq)
                     t=1.d0/(abs(theta)+sqrt(1.d0+theta**2))
                     if(theta.lt.0.d0)t=-t
                  endif
                  c=1.d0/sqrt(1.d0+t**2)
                  s=t*c
                  tau=s/(1.d0+c)
                  h=t*a(ip,iq)
                  z(ip)=z(ip)-h
                  z(iq)=z(iq)+h
                  d(ip)=d(ip)-h
                  d(iq)=d(iq)+h
                  a(ip,iq)=0.d0
                  do j=1,ip-1
                     g=a(j,ip)
                     h=a(j,iq)
                     a(j,ip)=g-s*(h+g*tau)
                     a(j,iq)=h+s*(g-h*tau)
                  enddo
                  do j=ip+1,iq-1
                     g=a(ip,j)
                     h=a(j,iq)
                     a(ip,j)=g-s*(h+g*tau)
                     a(j,iq)=h+s*(g-h*tau)
                  enddo
                  do j=iq+1,n
                     g=a(ip,j)
                     h=a(iq,j)
                     a(ip,j)=g-s*(h+g*tau)
                     a(iq,j)=h+s*(g-h*tau)
                  enddo
                  do j=1,n
                     g=v(j,ip)
                     h=v(j,iq)
                     v(j,ip)=g-s*(h+g*tau)
                     v(j,iq)=h+s*(g-h*tau)
                  enddo
                  nrot=nrot+1
               endif
            enddo
         enddo
         do ip=1,n
            b(ip)=b(ip)+z(ip)
            d(ip)=b(ip)
            z(ip)=0.d0
         enddo
      enddo
      write(6,'(''Too many iterations in jacobi'')')
      return
      end


subroutine zhbhstokesmatbuild(zk,wgeo,ncomp,nchs,ccs, &
  q1,q2,ntot,sysmat,ier)

  !
  ! This routine builds the matrix for solving
  ! a Dirichlet problem of the form
  !
  ! \Delta (\Delta + zk^2) u = 0 in the domain
  !
  ! with boundary conditions:
  !
  ! u = f
  ! d/dn u = g
  !
  ! on a bounded, multiply connected domain.
  ! The integral representation is based on the
  ! Stokes-type layer potentials
  !
  ! INPUT:
  !
  ! zk - COMPLEX *16, wavenumber of PDE
  ! wgeo - REAL *8 array, packed chunks description
  !        of boundary
  ! ncomp - INTEGER, number of boundary components
  !         the first boundary component should be
  !         the OUTER boundary
  ! nchs - INTEGER array, nchs(i) is the number of
  !        chunks on the ith boundary component. the
  !        chunks in wgeo should be ordered such that
  !        the first nchs(1) chunks comprise the 1st
  !        boundary component, etc.
  ! ccs - REAL *8 array, ccs(1:2,2:ncomp) describe
  !       point inside each of the connected
  !       boundary components
  ! q1 - COMPLEX *16, weight of single layer part
  !      of stokes rep
  ! q2 - COMPLEX *16, weight of double layer part
  !      of stokes rep
  ! ntot - INTEGER, size of sysmat. if ntot=-1
  !        ntot is the size ntot should be on
  !        return. Note that ntot=2*k*nch+ncomp
  !
  ! RETURN
  !
  ! ntot - INTEGER if ntot=-1 on entry, then ntot
  !        is the system size on return
  ! sysmat - COMPLEX *16, if ier = 0, then this
  !          should contain the system matrix as
  !          described in detail below.
  ! ier - INTEGER, error flag
  !        ier = 0 --> normal operation
  !        ier = 4 --> insufficient size matrix
  !        ier = 1024 --> query mode (NTOT=-1 on entry)
  !
  ! SYSTEM DESCRIPTION:
  !
  ! on simply connected q1 = 0, q2 = 1 are good
  ! choices. on multiply connected q1 = q2 = 1
  ! are good choices.
  !
  ! sysmat = ( A B )
  !          ( C D )
  !
  ! A = q1*S + q2*(D - 1/2), is the system matrix for
  ! a stokes layer potential. It is 2*number of
  ! boundary points-by-2*number of boundary points
  ! in dimension. The x and y directions of the
  ! vector field are interleaved, i.e. entries in
  ! the 2*j+1 columns correspond to the x directoin
  ! and entries in the 2*j columns correspond to the
  ! y directions.
  !
  ! B = a matrix corresponding to other parts of
  ! the representation. The first column is zero
  ! the remaining ncomp-1 columns correspond to
  ! the gradient of log charges in the holes of
  ! the domain.
  !
  ! C = a matrix corresponding to the integral of
  ! the stream function of the stokes field
  ! on each boundary component. This matrix requies some
  ! precomputation because of the potential field
  ! in the Stokes double layer representation
  !
  ! D = the integral of the constant added to
  ! the representation and the log charges along
  ! each boundary component.
  !
  ! The right hand side for this system matrix
  ! should be of the form
  !
  ! (G; I)
  !
  ! where G is the gradient of u and I is the
  ! integral of u along each boundary component
  !
  implicit none
  ! global
  complex *16 :: zk, q1, q2, sysmat(ntot,ntot)
  integer :: ncomp, nchs(*), ntot, ier
  real *8 :: wgeo(*), ccs(2,*)
  ! local
  complex *16, allocatable :: temp1(:,:),temp2(:,:), &
       xx(:,:), yy(:,:), stokesmat(:,:), work(:), xxlong(:,:), &
       yylongtrans(:,:), logval(:,:), logvalperp(:,:,:), brmat(:,:)
  real *8, allocatable :: rnorms(:,:), whts(:)
  real *8 :: eps, errs(1000), p1,p2,p3,p4
  real *8 :: time1, time2
  integer job, lw, ndim, ngmrec, numit, niter, j1
  integer k, nch, ichunks, iadjs, iders, iders2, ihs
  integer npts, i, j, iii, incx, incy, ind, npts2, jj, ii
  complex *16 :: zero, alpha, beta, pars1, pars2, one
  complex *16 :: val, grad(2), hess(2,2)
  data zero, one / (0.0d0,0.0d0), (1.0d0,0.0d0) /
  external zkernel_slp, zkernel_sprime
  external fgreenlap, chs_multatrans, fgreensdummy
  external zhelmstokes_stream_kern, zhelmstokes_kern

  ! get dimensions
  call chunkunpack1(wgeo,k,nch,ichunks,iadjs, &
       iders,iders2,ihs)

  ! normals and smooth integration weights
  allocate(rnorms(2,k*nch),whts(k*nch))
  call chunknormals(wgeo,rnorms)
  call chunkwhts(k,nch,wgeo(ichunks),wgeo(iders), &
       wgeo(ihs),whts)

  ier = 0

  npts = k*nch

  call prinf('npts*',npts,1)

  if (ntot .lt. 0) then
     ntot = 2*npts+ncomp
     ier = 1024
     return
  endif

  allocate(xx(npts,ncomp),yy(npts,ncomp))

  do i = 1,ncomp
     do j = 1,npts
        xx(j,i) = zero
        yy(j,i) = zero
     enddo
  enddo

  ! set up integration weights on separate components

  ind = 1
  do iii = 1,ncomp
     call prinf('ind *',ind,1)
     do i = 1,nchs(iii)
        do j = 1,k
           xx(ind,iii) = whts(ind)
           ind = ind+1
        enddo
     enddo
  enddo

  call prinf('ind *',ind,1)

  ! charges and constants

  allocate(logval(npts,ncomp),logvalperp(2,npts,ncomp), &
       brmat(ncomp,ncomp))

  ! constant

  do j = 1,npts
     logval(j,1) = one
     logvalperp(1,j,1) = zero
     logvalperp(2,j,1) = zero
  enddo

  ! log charge

  do i = 2,ncomp
     do j = 1,npts
        call fgreenlap(zk,ccs(1,i),wgeo(ichunks+2*(j-1)), &
             pars1,pars2,val,grad,hess)
        logval(j,i) = val
        logvalperp(1,j,i) = -grad(2)
        logvalperp(2,j,i) = grad(1)
     enddo
  enddo

  ! bottom right matrix is integral of these charges
  ! on each component

  beta = 0.0d0
  incx = 1
  incy = 1
  alpha = 1.0d0

  !call zgemm('T','N',ncomp,ncomp,npts,alpha,xx, &
  !     npts,logval,npts,beta,brmat,ncomp)

  call chs_multgentransmat(xx,logval,brmat,npts,ncomp,ncomp)

  ! copy into system matrix
  ! (bottom right)

  do i = 1,ncomp
     do j = 1,ncomp
        sysmat(2*npts+j,2*npts+i) = brmat(j,i)
     enddo
  enddo

  ! copy velocity due to charges into system matrix
  ! (top right)

  do i = 1,ncomp
     ii = i+2*npts
     do j = 1,npts
        jj = 2*j-1
        sysmat(jj,ii) = logvalperp(1,j,i)
        jj = 2*j
        sysmat(jj,ii) = logvalperp(2,j,i)
     enddo
  enddo

  ! single layer evaluation matrix in temp1
  allocate(temp1(npts,npts),temp2(npts,npts))
  call prinf('forming slp ...*',i,0)
  call zbuildmat(k,wgeo,zkernel_slp,q1,q2, &
       fgreenlap,zk,pars1,pars2,npts,temp1)
  call prinf('done.*',i,0)

  beta = 0.0d0
  incx = 1
  incy = 1
  alpha = 1.0d0

  ! apply transpose to weights vectors (1 per
  ! boundary component)
  !call zgemm('T','N',npts,ncomp,npts,alpha,temp1, &
  !     npts,xx,npts,beta,yy,npts)

  call chs_multgentransmat(temp1,xx,yy,npts,npts,ncomp)

  ! matrix for neumann problem in temp2
  call prinf('forming sprime ...*',i,0)
  call zbuildmat(k,wgeo,zkernel_sprime,q1,q2, &
       fgreenlap,zk,pars1,pars2,npts,temp2)
  call prinf('done.*',i,0)
  do i = 1,npts
     temp2(i,i) = temp2(i,i) + 0.5d0
  enddo
  do j = 1,npts
     do i = 1,npts
        temp2(i,j) = temp2(i,j) + whts(j)
     enddo
  enddo

  ! solve transpose problem for each yy vector

  ngmrec = 200
  numit = 200
  lw = (ngmrec*2 + 4)*npts
  allocate(work(lw))
  job = 0
  ier = 0
  eps = 1.0d-14

  do i = 1,ncomp
     call prinf('solving neumann problem, comp *',i,1)

     call cgmres(ier,npts,temp2,chs_multatrans, &
          p1,p2,p3,p4,yy(1,i), &
          eps,numit,xx(1,i),niter,errs,ngmrec,work)
     call prin2('errs *',errs,niter)
  enddo
  call prinf('done with all Neumann problems.*',i,0)
  ! form S_tau

  call prinf('forming stau ...*',i,0)
  do i = 1,npts
     ndim = 2
     call chunkderf(temp1(1,i),temp2(1,i),ndim,k,nch, &
          wgeo(ichunks),wgeo(iders),wgeo(ihs))
  enddo
  call prinf('done*',i,0)

  ! apply Stau transpose to solutions of transpose problem
  beta = 0.0d0
  incx = 1
  incy = 1
  alpha = 1.0d0

  call prinf('applying stau ...*',i,0)
  !call zgemm('T','N',npts,ncomp,npts,alpha,temp2, &
  !     npts,xx,npts,beta,yy,npts)
  call chs_multgentransmat(temp2,xx,yy,npts,npts,ncomp)
  call prinf('done.*',i,0)

  ! get whts^T*stream matrix

  npts2 = 2*npts
  allocate(xxlong(npts2,ncomp),yylongtrans(ncomp,npts2))
  allocate(stokesmat(npts2,npts2))

  ndim = 2
  call prinf('building stream function evaluator ...*',i,0)
  time1 = second()
  call zbuildmat_vec(ndim,k,wgeo,zhelmstokes_stream_kern, &
       q1,q2,fgreensdummy,zk,pars1,pars2,npts2, &
       stokesmat)
  time2 = second()
  call prin2('done.*',time2-time1,1)

  do i = 1,ncomp
     do j = 1,npts2
        xxlong(j,i) = zero
     enddo
  enddo

  do i = 1,npts2
     do j = 1,ncomp
        yylongtrans(j,i) = zero
     enddo
  enddo

  ! set up integration weights on separate components

  ind = 1
  do iii = 1,ncomp
     call prinf('ind *',ind,1)
     do i = 1,nchs(iii)
        do j = 1,k
           xxlong(2*ind-1,iii) = whts(ind)
           ind = ind+1
        enddo
     enddo
  enddo

  ! integrate stream function matrix

  !call zgemm('T','N',ncomp,npts2,npts2,alpha,xxlong, &
  !     npts2,stokesmat,npts2,beta,yylongtrans,ncomp)

  call chs_multgentransmat(xxlong,stokesmat,yylongtrans,npts2,ncomp,npts2)

  ! add these components together and store in
  ! system matrix (bottom left)

  do j = 1,npts
     do j1 = 1,2
        do i = 1,ncomp
           jj = 2*j-2+j1
           sysmat(npts2+i,jj) = yylongtrans(i,jj) - &
                q2*yy(j,i)*rnorms(j1,j)
        enddo
     enddo
  enddo

  ! get stokes system matrix (top left)

  ndim = 2
  call prinf('building stokes kernel ...*',i,0)
  time1 = second()
  call zbuildmat_vec(ndim,k,wgeo,zhelmstokes_kern, &
       q1,q2,fgreensdummy,zk,pars1,pars2,npts2, &
       stokesmat)
  time2 = second()
  call prin2('done.*',time2-time1,1)

  ! copy in (top left)

  do i = 1,npts2
     do j = 1,npts2
        sysmat(j,i) = stokesmat(j,i)
     enddo
  enddo

  ! add onesmat modification

  call prinf('building nullspace correction ...*',i,0)
  call normalonesmat(stokesmat,whts,rnorms,k,nch)
  call prinf('done.*',i,0)
  do j = 1,npts2
     do i = 1,npts2
        sysmat(i,j) = sysmat(i,j) + stokesmat(i,j)
        if (i .eq. j) sysmat(i,j) = sysmat(i,j)-0.5d0*q2
     enddo
  enddo

  return
end subroutine zhbhstokesmatbuild

subroutine fgreenlap(par0,src,targ,pars1,pars2,val, &
     grad,hess)
  implicit real *8 (a-h,o-z)
  real *8, intent(in) :: src(2), targ(2)
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(out) :: val, grad(2), hess(2,2)
  ! local
  real *8 :: pi2, rx, ry, pi, r2, r4, r, rx2, ry2

  pi2 = 8.0d0*atan(1.0d0)
  pi = pi2/2.0d0
  rx = targ(1)-src(1)
  ry = targ(2)-src(2)

  rx2 = rx*rx
  ry2 = ry*ry

  r2 = rx2 + ry2
  r4 = r2*r2
  r = sqrt(r2)

  val = -log(r)/pi2
  grad(1) = -rx/(r2*pi2)
  grad(2) = -ry/(r2*pi2)

  hess(1,1) = rx2/(pi*r4)-1.0d0/(pi2*r2)
  hess(2,1) = rx*ry/(pi*r4)
  hess(1,2) = hess(2,1)
  hess(2,2) = ry2/(pi*r4)-1.0d0/(pi2*r2)

  return
end subroutine fgreenlap

subroutine chs_multatrans(a,p1,p2,p3,p4,x,y,n)
  implicit real *8 (a-h,o-z)
  !
  !       computes the product a^T*x = y
  !
  complex *16 a(n,*),p1,p2,p3,p4,x(*),y(*)
  complex *16 alpha, beta

  beta = 0.0d0
  incx = 1
  incy = 1
  alpha = 1.0d0

  !call zgemv ('T', n, n, alpha, a, n, x, incx, beta, y, incy)

  do i = 1,n
     y(i) = 0.0d0
     do j = 1,n
        y(i) = y(i) + a(j,i)*x(j)
     enddo
  enddo

  return
end subroutine chs_multatrans

subroutine chs_multgentransmat(a,x,y,m,n,l)
  implicit real *8 (a-h,o-z)
  !
  !       computes the product a^T*x = y
  !
  complex *16 a(m,n),x(m,l),y(n,l)
  integer :: n,m,k,i,j,l

  do k = 1,l
     do i = 1,n
        y(i,k) = 0.0d0
        do j = 1,m
           y(i,k) = y(i,k) + a(j,i)*x(j,k)
        enddo
     enddo
  enddo

  return
end subroutine chs_multgentransmat


  subroutine ss_phasematrix( &
    k,        maxlay,   nstokes,    &
    maxleg,   maxstr,   maxintstr,  &
    ngeomax,  ntrunc,   phi,        &
    gmu,      imuv,     imu0,       &
    plm_0,    plm_m,    plm_p,      &
    u,        phase,    Z_ss)

!-----------------------------------------------------------
! Subroutine:
!   ss_phasematrix
!
! Purpose:
!   Returns phase matrix for single scattering geometry
!
! Output:
!
!
! Fourier expansion
!
!           ntrunc
! Z = 0.5 *  SUM   (2-d0m) * { Bmplus * Zm * EpDelta +
!                                Bmmin  * Zm * EmDelta }
!
! where EpDelta = E + Delta and
!       EmDelta = E - Delta with
!       E = diag(1,1,1,1) and
!       Delta = diag(1,1,-1,-1)
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8)!double precision

  integer,intent(in):: &
     maxlay,        &
     nstokes,       &
     maxleg,        &
     maxstr,        &
     maxintstr,     &
     ngeomax,       &
     imuv(ngeomax), &
     imu0(ngeomax)

  real(kind=dp),intent(in):: &
     phi(ngeomax), &
     gmu(maxstr), &
     phase(nstokes,nstokes,0:maxleg,maxlay) !phase fct. moments

  real(kind=dp), &
    dimension(0:maxleg,0:maxleg,maxintstr+4*ngeomax),intent(in):: &
     plm_0, &
     plm_m, &
     plm_p
  real(kind=dp),intent(in):: &
     u(maxintstr+4*ngeomax)

  real(kind=dp):: &
     pi,               &
     deg2rad,          & !
     dfac,             & ! 0.5 * (2-d0m)
     Bmplus(4,ngeomax), &
     Bmmin(4,ngeomax), &
     Zm_ss(4,ngeomax), &
     Delta(4), &
     EmDelta(4), &
     EpDelta(4)

  integer:: &
    imuvp, &
    imuvm, &
    imu0p, &
    imu0m

  integer:: &
     k,i_st,l,m,ntrunc,iv

  real(kind=dp),parameter:: &
     eps = 1.d-50

  real(kind=dp),intent(out):: &
     Z_ss(nstokes,maxlay,ngeomax)

!-----------------------------------------------------------------------

  pi = 2.d0*asin(1.d0)
  deg2rad = pi/180.d0

  Delta(1) =  1.d0
  Delta(2) =  1.d0
  Delta(3) = -1.d0
  Delta(4) = -1.d0

  EpDelta(1:4) = 1.d0+Delta(1:4)
  EmDelta(1:4) = 1.d0-Delta(1:4)

  do iv=1,ngeomax

     imuvp = maxintstr+0*ngeomax+iv ! +uv
     imu0m = maxintstr+1*ngeomax+iv ! -u0
     imuvm = maxintstr+2*ngeomax+iv ! -uv
     imu0p = maxintstr+3*ngeomax+iv ! +u0

     do i_st = 1,nstokes
        Z_ss(i_st,k,iv) = 0.d0
     enddo

     do m = 0,ntrunc

        do i_st = 1,4
           Zm_ss(i_st,iv) = 0.d0
        enddo

!       0.5 * (2-d0m)
        dfac = 0.5 * 2.0d0
        if(m.eq.0) dfac = 0.5d0 * 1.0d0

        Bmplus(1,iv) = cos(dble(m)*(phi(iv)*deg2rad))
        Bmplus(2,iv) = cos(dble(m)*(phi(iv)*deg2rad))
        Bmplus(3,iv) = sin(dble(m)*(phi(iv)*deg2rad))
        Bmplus(4,iv) = sin(dble(m)*(phi(iv)*deg2rad))

        Bmmin(1,iv) = -sin(dble(m)*(phi(iv)*deg2rad))
        Bmmin(2,iv) = -sin(dble(m)*(phi(iv)*deg2rad))
        Bmmin(3,iv) =  cos(dble(m)*(phi(iv)*deg2rad))
        Bmmin(4,iv) =  cos(dble(m)*(phi(iv)*deg2rad))

        do l = m,ntrunc

           Zm_ss(1,iv) = Zm_ss(1,iv) + &
                                plm_0(m,l,imuvp) * &
                                 phase(1,1,l,k) * &
                                  plm_0(m,l,imu0m)

           Zm_ss(2,iv) = Zm_ss(2,iv) + &
                                plm_p(m,l,imuvp) * &
                                 phase(2,1,l,k) * &
                                  plm_0(m,l,imu0m)

           Zm_ss(3,iv) = Zm_ss(3,iv) + &
                                plm_m(m,l,imuvp) * &
                                 phase(2,1,l,k) * &
                                  plm_0(m,l,imu0m)

           Zm_ss(4,iv) = 0.d0

        enddo

!       truncate sum to speed things up
        if((abs(EpDelta(i_st) * &
                 dfac * Bmplus(i_st,iv) * &
                  Zm_ss(i_st,iv) + &
                EmDelta(i_st) * &
                 dfac * Bmmin(i_st,iv) * &
                  Zm_ss(i_st,iv)).lt.eps).and.(m.gt.2))then
            goto 11
        endif

        do i_st = 1,nstokes
           Z_ss(i_st,k,iv) = Z_ss(i_st,k,iv) + &
                              EpDelta(i_st) * &
                               dfac * Bmplus(i_st,iv) * &
                                Zm_ss(i_st,iv) + &
                              EmDelta(i_st) * &
                               dfac * Bmmin(i_st,iv) * &
                                Zm_ss(i_st,iv)
        enddo

    enddo

 11 continue

  enddo

  return
  end subroutine ss_phasematrix


!
! Stopping poweer models from the literature.
!
!

! Fraley et al.
! Phys of Fluids 17 (1974) 474
!
! Stopping power for an alpha in DT is given on p. 475. It depends only upon
! the alpha particle density and the electron temperature.
!
      SUBROUTINE dedx_fraley(nni, ep, mb, nb, betab, dedx_tot, dedx_i, dedx_e)
      USE physvars
      USE mathvars
        IMPLICIT NONE                                         ! Plasma:
        INTEGER,                     INTENT(IN)  :: nni       !  number of ions
        REAL,                        INTENT(IN)  :: ep        !  projectile energy [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb        !  mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb        !  number density array [cm^-3]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab     !  temp array [1/keV]

                                                              !
                                                              ! dE/dx [MeV/micron]
        REAL,                        INTENT(OUT) :: dedx_tot  !  electron + ion
        REAL,                        INTENT(OUT) :: dedx_i    !  ion contribution
        REAL,                        INTENT(OUT) :: dedx_e    !  electron contribution

        REAL,    PARAMETER           :: units=1.E-7        ! 10^-7 => MeV/micron; 10^-4 keV/micron
        REAL,    PARAMETER           :: MKEV2G=1.78273E-30 ! convert mass in keV/c^2 to g
        REAL,    PARAMETER           :: E0=3500.           ! threshold alpha energy in keV
        REAL,    PARAMETER           :: RHO0=0.213         ! g/cm^3 density of solid DT
        REAL     :: te, u, rho

!       REAL,    DIMENSION(1:nni+1)  :: kkb2, aab, ab2, c1b, c2b, c3b,c4b, eetb
!
! initialize components of dE/dx
!

       te =1./betab(1) ! electron temp in keV
       u  =ep/E0       ! normalized alpha particle energy
       rho=SUM(mb(1:nni+1)*nb(1:nni+1))*MKEV2G  ! total mass density of DT plasma in g/cm^3

       dedx_e=23.2*(rho/RHO0)*(u**0.5/te**1.5)*(1 + 0.17*LOG(te*SQRT(RHO0/rho)))*E0*units
       dedx_i=0.047*(rho/RHO0)*(1/u)*(1 + 0.075*LOG(SQRT((te*RHO0)/(rho*u))))*E0*units

       dedx_tot = dedx_e + dedx_i

      END SUBROUTINE dedx_fraley

! simple model for the transition to strong coupling. Note: the coefficients d_i
! and d_e should have an unknown energy dependence in the strong regime.
!
!
      SUBROUTINE dedx_bps_strong1(nni, ep, zp, mp, betab, zb, mb, nb, d_i, d_e,  &
            dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, dedxc_e, &
            dedxq_tot, dedxq_i, dedxq_e)
      USE physvars
      USE mathvars
        IMPLICIT NONE                                      ! Plasma:
        INTEGER,                     INTENT(IN)  :: nni    !  number of ions
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  temp array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  density [1/cc]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  charge array
        REAL,                        INTENT(IN)  :: d_i    !  strong coupling ion parameter
        REAL,                        INTENT(IN)  :: d_e    !  strong coupling electron parameter
                                                           !
                                                           ! Projectile
        REAL,                        INTENT(IN)  :: ep     !  projectile energy [keV]
        REAL,                        INTENT(IN)  :: mp     !  projectile mass   [keV]
        REAL,                        INTENT(IN)  :: zp     !  projectile charge
                                                           !
                                                              ! dE/dx [MeV/micron]
        REAL,                        INTENT(OUT) :: dedx_tot  !  electron + ion
        REAL,                        INTENT(OUT) :: dedx_i    !  ion contribution
        REAL,                        INTENT(OUT) :: dedx_e    !  electron contribution
        REAL,                        INTENT(OUT) :: dedxc_tot !  classical
        REAL,                        INTENT(OUT) :: dedxc_i   !  classical
        REAL,                        INTENT(OUT) :: dedxc_e   !  classical
        REAL,                        INTENT(OUT) :: dedxq_tot !  quantum
        REAL,                        INTENT(OUT) :: dedxq_i   !  quantum
        REAL,                        INTENT(OUT) :: dedxq_e   !  quantum

        REAL                        :: st_i, st_e
        REAL,    DIMENSION(1:nni+1) :: gb   !  Plasma coupling array
        REAL                        :: ge   !  Electron coupling
        REAL                        :: gi   !  Average ion coupling
        REAL                        :: etae !  Quantum parameter for electron
        REAL                        :: ze   !  Fugacity

! Call weakly coupled BPS stopping power
!
        CALL dedx_bps(nni, ep, zp, mp, betab, zb, mb, nb,   &
             dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i,  &
             dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]

! Calculate plasma coupling constant g
!
        CALL param(nni, betab, nb, gb, ge, gi, etae, ze)
        st_i = 1. + ge*d_i
        st_e = 1. + ge*d_e

        dedx_i    = dedx_i*st_i
        dedx_e    = dedx_e*st_e
        dedx_tot  = dedx_i + dedx_e

        dedxc_i   = dedxc_i*st_i
        dedxc_e   = dedxc_e*st_e
        dedxc_tot = dedxc_i + dedxc_e

        dedxq_i   = dedxq_i*st_i
        dedxq_e   = dedxq_e*st_e
        dedxq_tot = dedxq_i + dedxq_e

      END SUBROUTINE dedx_bps_strong1


c ----------------------------------------------------------------------
c
      subroutine jiocxx(fic,foc,gc,vmass,vwidth , jioc)
c
c This subroutine computes an off-shell vector current from an external
c antifermion pair. The vector boson propagator is given in Feynman
c gauge for a massless vector and in unitary gauge for a massive vector.
c
c input:
c       complex fic(6)         : flow-in  antifermion              |fic>
c       complex foc(6)         : flow-out antifermion              <foc|
c       complex gc(2)          : coupling constants                  gvf
c       real    vmass          : mass  of output vector v
c       real    vwidth         : width of output vector v
c
c output:
c       complex jioc(6)        : vector current        j^mu(<foc|v|fic>)
c
      implicit none
      double complex fic(6),foc(6),gc(2),jioc(6),c0,c1,c2,c3,cs,d
      double precision q(0:3),vmass,vwidth,q2,vm2,dd
      double complex cm2 ! mass**2- I Gamma mass (Benj&Claude)

      double precision rZero, rOne
      parameter( rZero = 0.0d0, rOne = 1.0d0 )
      double complex cImag, cZero
      parameter( cImag = ( 0.0d0, 1.0d0 ), cZero = ( 0.0d0, 0.0d0 ) )
c
      jioc(5) = foc(5)-fic(5)
      jioc(6) = foc(6)-fic(6)

      q(0) = dble( jioc(5))
      q(1) = dble( jioc(6))
      q(2) = dimag(jioc(6))
      q(3) = dimag(jioc(5))
      q2 = q(0)**2-(q(1)**2+q(2)**2+q(3)**2)
      vm2 = vmass**2

      if ( vmass.ne.rZero ) then

         d = -rOne/dcmplx( q2-vm2, vmass*vwidth )
c  for the running width, use below instead of the above d.
c         d = -rOne/dcmplx( q2-vm2, max(vwidth*q2/vmass,rZero) )

         if ( gc(2).ne.cZero ) then
            c0=  gc(2)*( foc(3)*fic(1)+foc(4)*fic(2))
     &          +gc(1)*( foc(1)*fic(3)+foc(2)*fic(4))
            c1= -gc(2)*( foc(3)*fic(2)+foc(4)*fic(1))
     &          +gc(1)*( foc(1)*fic(4)+foc(2)*fic(3))
            c2=( gc(2)*( foc(3)*fic(2)-foc(4)*fic(1))
     &          +gc(1)*(-foc(1)*fic(4)+foc(2)*fic(3)))*cImag
            c3=  gc(2)*(-foc(3)*fic(1)+foc(4)*fic(2))
     &          +gc(1)*( foc(1)*fic(3)-foc(2)*fic(4))
         else
            d = d*gc(1)
            c0 =  foc(1)*fic(3)+foc(2)*fic(4)
            c1 =  foc(1)*fic(4)+foc(2)*fic(3)
            c2 =(-foc(1)*fic(4)+foc(2)*fic(3))*cImag
            c3 =  foc(1)*fic(3)-foc(2)*fic(4)
         end if

c     Fabio's implementation of the fixed width (Benj&Claude)
         cm2=dcmplx( vm2, -vmass*vwidth )
c         cs = (q(0)*c0-q(1)*c1-q(2)*c2-q(3)*c3)/vm2
         cs = (q(0)*c0-q(1)*c1-q(2)*c2-q(3)*c3)/cm2

         jioc(1) = (c0-cs*q(0))*d
         jioc(2) = (c1-cs*q(1))*d
         jioc(3) = (c2-cs*q(2))*d
         jioc(4) = (c3-cs*q(3))*d

      else

         d = dcmplx( -rOne/q2, rZero )
         if ( gc(2).ne.cZero ) then
            jioc(1) = ( gc(2)*( foc(3)*fic(1)+foc(4)*fic(2))
     &                 +gc(1)*( foc(1)*fic(3)+foc(2)*fic(4)) )*d
            jioc(2) = (-gc(2)*( foc(3)*fic(2)+foc(4)*fic(1))
     &                 +gc(1)*( foc(1)*fic(4)+foc(2)*fic(3)) )*d
            jioc(3) = ( gc(2)*( foc(3)*fic(2)-foc(4)*fic(1))
     &                 +gc(1)*(-foc(1)*fic(4)+foc(2)*fic(3)) )
     &                *d*cImag
            jioc(4) = ( gc(2)*(-foc(3)*fic(1)+foc(4)*fic(2))
     &                 +gc(1)*( foc(1)*fic(3)-foc(2)*fic(4)) )*d
         else
            d = d*gc(1)
            jioc(1) = ( foc(1)*fic(3)+foc(2)*fic(4))*d
            jioc(2) = ( foc(1)*fic(4)+foc(2)*fic(3))*d
            jioc(3) = (-foc(1)*fic(4)+foc(2)*fic(3))*d*cImag
            jioc(4) = ( foc(1)*fic(3)-foc(2)*fic(4))*d
         end if

      end if
c
      return
      end


C MUHOPT.f   - Gateway function to compute the mu optimal or H_inf
C              controller using SLICOT routines SB10AD, SB10MD, AB04MD,
C              AB05MD, and AB07ND.
C
C RELEASE 2.0 of SLICOT Robust Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2004-2020 NICONET e.V.
C
C Matlab call:
C   If mu optimal controller is desired (job > 0):
C
C   [AK,BK,CK,DK(,mju,RCOND)] = muHopt(job,discr,A,B,C,D,ncon,nmeas,
C                gamma,omega,nblock,itype,ord(,qutol(,gtol(,actol))))
C
C   If H_inf optimal controller is only desired (job <= 0):
C
C   [AK,BK,CK,DK(,gammin,RCOND)] = muHopt(job,discr,A,B,C,D,ncon,
C                nmeas,gamma(,gtol(,actol)))
C
C Purpose:
C   To compute the matrices of the mu optimal or H_inf optimal
C   controller given the model in a state space. It also outputs the
C   mu norm of the closed loop system, if mu optimal controller is
C   desired, or the value of gamma reached in the H_inf synthesis
C   problem, if H_inf controller is only desired.
C   The discrete-time systems are handled via bilinear transformation
C   to continuous-time and then the controller obtained is discretised.
C   For the K step the SB10AD subroutine is employed, and the SB10MD
C   subroutine performs the D step.
C
C Input parameters:
C   job    - indicates the type of the controller as well as the strategy
C            for reducing the gamma value:
C            >  0 : mu optimal controller is desired;
C            <= 0 : H_inf optimal controller only is desired.
C            Specifically, job
C            = 0 : find suboptimal controller only;
C            and abs(job) specifies the strategy for reducing gamma:
C            = 1 : use bisection method for decreasing gamma from gamma
C                  to gammin until the closed-loop system leaves
C                  stability;
C            = 2 : scan from gamma to 0 trying to find the minimal gamma
C                  for which the closed-loop system retains stability;
C            = 3 : first bisection, then scanning.
C   discr  - indicates the type of the system, as follows:
C            = 0 : continuous-time system;
C            = 1 : discrete-time system.
C   A      - the n-by-n system state matrix A of the plant.
C   B      - the n-by-m system input matrix B of the plant.
C   C      - the p-by-n system output matrix C of the plant.
C   D      - the p-by-m system input/output matrix D of the plant.
C   ncon   - the number of control inputs.
C            p-nmeas >= ncon >= 0.
C   nmeas  - the number of measurements.
C            p-nmeas = m-ncon >= nmeas >= 0.
C   gamma  - the initial value of gamma on input. It is assumed that
C            gamma is sufficiently large so that the controller is
C            admissible.  gamma >= 0.
C   omega  - the vector of length lendat >= 2 with the frequencies.
C            They must be nonnegative, in increasing order, and
C            for discrete-time systems between 0 and pi.
C   nblock - the vector with the block structure of the uncertainty.
C            nblock(I) is the size of each block.
C   itype  - the vector of the same length as nblock indicating
C            the type of each block.
C            itype(I) = 1 indicates that the corresponding block is a
C            real block. THIS OPTION IS NOT SUPPORTED NOW.
C            itype(I) = 2 indicates that the corresponding block is a
C            complex block. THIS IS THE ONLY ALLOWED VALUE NOW!
C   ord    - the maximum order of each block in the D-fitting procedure.
C            1 <= ord <= lendat-1.
C   qutol  - (optional) the acceptable mean relative error between
C            the D(jw) and the frequency response of the estimated block
C            [ADi,BDi;CDi,DDi]. When it is reached, the result is
C            taken as good enough.
C            Default: qutol = 2.
C   gtol   - (optional) tolerance used for controlling the accuracy
C            of gamma and its distance to the estimated minimal possible
C            value of gamma.
C            If gtol <= 0, then sqrt(EPS) is used, where EPS is the
C            relative machine precision.
C            Default: gtol = 0.01.
C   actol  - (optional) upper bound for the poles of the closed-loop
C            system used for determining if it is stable.
C            actol <= 0 for stable systems.
C            Default: actol = 0.
C
C Output parameters:
C   AK     - the n-by-n controller state matrix AK.
C   BK     - the n-by-nmeas controller input matrix BK.
C   CK     - the ncon-by-n controller output matrix CK.
C   DK     - the ncon-by-nmeas controller input/output matrix DK.
C   mju    - (optional) the vector with the estimated upper bound of
C            the structured singular value for each frequency in omega
C            for the closed-loop system.
C   gammin - (optional) the estimated minimal admissible gamma.
C   RCOND  - (optional) for each successful J-th K step:
C            RCOND(J) contains the reciprocal condition number of the
C                     control transformation matrix;
C            RCOND(J+1) contains the reciprocal condition number of the
C                     measurement transformation matrix;
C            RCOND(J+2) contains an estimate of the reciprocal condition
C                     number of the X-Riccati equation;
C            RCOND(J+3) contains an estimate of the reciprocal condition
C                     number of the Y-Riccati equation.
C            If job = 0, only RCOND(1:4) are set by the first K step.
C
C Contributor:
C   A. Markovski, Technical University of Sofia, October 2003.
C
C Revisions:
C   V. Sima, April 2004, Sept. 2004, Mar. 2005, Apr. 2009, Dec. 2012.
C
C***********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      INTEGER           MAXIT, HNPTS
      PARAMETER         ( MAXIT = 15, HNPTS = 2048 )
      DOUBLE PRECISION  ZERO, ONE, TWO, P01
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                    P01  = 0.01D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Parameters used by SLICOT subroutines ..
      INTEGER           F, INFO, JOB, LBWORK, LDA, LDAC, LDAD, LDAE,
     $                  LDAK, LDB, LDBC, LDBD, LDBE, LDBK, LDC, LDCC,
     $                  LDCD, LDCE, LDCK, LDD, LDDC, LDDD, LDDE, LDDK,
     $                  LDWORK, LENDAT, LIWORK, LZWORK, M, M2, MNB, N,
     $                  N2E, NE, NEB, NP, NP1, NP2, NTEMP, ORD, TOTORD
      DOUBLE PRECISION  ACTOL, GAMMA, GTOL, QUTOL, TEMP
      DOUBLE PRECISION  RCOND(4*MAXIT)
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      LOGICAL,          ALLOCATABLE :: BWORK(:)
      INTEGER,          ALLOCATABLE :: ITYPE(:), IWORK(:), NBLOCK(:)
      DOUBLE PRECISION, ALLOCATABLE :: A(:), AC(:), AD(:), AE(:), AK(:),
     $                                 AKB(:), B(:), BC(:), BD(:),
     $                                 BE(:), BK(:), BKB(:), C(:),
     $                                 CC(:), CD(:), CE(:), CK(:),
     $                                 CKB(:), D(:), DC(:), DD(:),
     $                                 DE(:), DK(:), DKB(:), DWORK(:),
     $                                 MJU(:), OMEGA(:), PMJU(:),
     $                                 RITYPE(:), RNBLCK(:)
      COMPLEX*16,       ALLOCATABLE :: ZWORK(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER         CONJOB
      CHARACTER*120     TEXT
      INTEGER           DISCR, I, IP, ITER, ITERB, LD1, LD2, LD3, LD4,
     $                  LI1, LI2, LI3, LI4, LW1, LW2, LW3, LW4, LW5,
     $                  LW6, LW7, LWA, LWB, LZD, LZM, M1, M11, MD, MIT,
     $                  MN, NA, NB, NC, ND, NIT, NNB, NP11
      DOUBLE PRECISION  PMPEAK, MUPEAK, TOL
C
C .. External functions ..
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH
C
C .. External subroutines ..
      EXTERNAL          AB04MD, AB05MD, AB07ND, DCOPY, SB10AD, SB10MD
C
C ..Intrinsic functions..
      INTRINSIC         ABS, COS, INT, MAX, MIN, SQRT
C
C Check for proper number of arguments.
C
      IF ( NRHS.EQ.0 ) THEN
         CALL mexErrMsgTxt( 'Matlab call: [AK,BK,CK,DK,MJU,RCOND]='//
     $ 'MUHOPT(JOB,DISCR,A,B,C,D,NCON,NMEAS,GAMMA,OMEGA,NBLOCK,ITYPE,'//
     $ 'ORD[,QUTOL[,GTOL[,ACTOL]]]) or [AK,BK,CK,DK,GAMMIN,RCOND]='//
     $ 'MUHOPT(JOB,DISCR,A,B,C,D,NCON,NMEAS,GAMMA[,GTOL[,ACTOL]])')
      ELSE IF ( NRHS.LT.9 ) THEN
         CALL mexErrMsgTxt
     $                 ( 'MUHOPT requires at least 9 input arguments' )
      ELSE IF ( NRHS.GT.16 ) THEN
         CALL mexErrMsgTxt
     $                 ( 'MUHOPT requires at most 16 input arguments' )
      ELSE IF ( NLHS.LT.4 ) THEN
         CALL mexErrMsgTxt
     $                 ( 'MUHOPT requires at least 4 output arguments' )
      END IF
C
C  job
C
      IF ( mxGetM( PRHS(1) ).NE.1 .OR. mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'JOB must be a scalar' )
      ELSE IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $          mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'JOB must be an integer scalar' )
      END IF
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), TEMP, 1 )
      JOB = INT( TEMP )
C
      IF ( ABS( JOB ).GT.3 ) THEN
         CALL mexErrMsgTxt( 'JOB has -3, -2, -1, 0, 1, 2, or 3 '//
     $                      'the only admissible values' )
      END IF
C
C     Determine the job.
C
      IF ( JOB.GT.0 ) THEN
C        mu controller desired.
         CONJOB = 'M'
      ELSE
C        H_inf controller desired.
         CONJOB = 'H'
         IF ( JOB.EQ.0 ) THEN
            JOB = 4
         ELSE
            JOB = ABS( JOB )
         END IF
      END IF
C
C     Recheck for proper number of arguments.
C
      IF ( CONJOB.EQ.'M' .AND. NRHS.LT.13 ) THEN
         CALL mexErrMsgTxt( 'MUHOPT requires at least 13 input '//
     $                  'arguments if mu optimal controller is desired')
      ELSE IF ( CONJOB.EQ.'H' .AND. NRHS.GT.11 ) THEN
         CALL mexErrMsgTxt( 'MUHOPT requires at most 11 input '//
     $               'arguments if H_inf optimal controller is desired')
      END IF
C
C  discr
C
      IF ( mxGetM( PRHS(2) ).NE.1 .OR. mxGetN( PRHS(2) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'DISCR must be a scalar' )
      ELSE IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $          mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'DISCR must be an integer scalar' )
      END IF
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), TEMP, 1 )
      DISCR = INT( TEMP )
C
      IF ( DISCR.LT.0 .OR. DISCR.GT.1 ) THEN
         CALL mexErrMsgTxt( 'DISCR must be 0 or 1' )
      END IF
C
C  A, B, C, D
C
      IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a numeric matrix' )
      END IF
C
      N  = mxGetM( PRHS(3) )
      NA = mxGetN( PRHS(3) )
C
      IF ( NA.NE.N ) THEN
         CALL mexErrMsgTxt( 'A must be a square matrix' )
      END IF
C
      IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(4) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'B must be a numeric matrix' )
      END IF
C
      NB = mxGetM( PRHS(4) )
      M  = mxGetN( PRHS(4) )
C
      IF ( NB.NE.N ) THEN
         CALL mexErrMsgTxt( 'B must have the same row dimension as A' )
      END IF
C
      IF ( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(5) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'C must be a numeric matrix' )
      END IF
C
      NP = mxGetM( PRHS(5) )
      NC = mxGetN( PRHS(5) )
C
      IF ( NC.NE.N ) THEN
         CALL mexErrMsgTxt
     $                 ( 'C must have the same column dimension as A' )
      END IF
C
      IF ( mxIsNumeric( PRHS(6) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(6) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'D must be a numeric matrix' )
      END IF
C
      ND = mxGetM( PRHS(6) )
      MD = mxGetN( PRHS(6) )
C
      IF ( ND.NE.NP ) THEN
         CALL mexErrMsgTxt( 'D must have the same row dimension as C' )
      ELSE IF ( MD.NE.M ) THEN
         CALL mexErrMsgTxt
     $                 ( 'D must have the same column dimension as B' )
      END IF
C
C  ncon (M2), nmeas (NP2)
C
      IF ( mxGetM( PRHS(7) ).NE.1 .OR. mxGetN( PRHS(7) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'NCON must be a scalar' )
      ELSE IF ( mxIsNumeric( PRHS(7) ).EQ.0 .OR.
     $          mxIsComplex( PRHS(7) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'NCON must be an integer scalar' )
      END IF
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(7) ), TEMP, 1 )
      M2 = INT( TEMP )
C
      IF ( mxGetM( PRHS(8) ).NE.1 .OR. mxGetN( PRHS(8) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'NMEAS must be a scalar' )
      ELSE IF ( mxIsNumeric( PRHS(8) ).EQ.0 .OR.
     $          mxIsComplex( PRHS(8) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'NMEAS must be an integer scalar' )
      END IF
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(8) ), TEMP, 1 )
      NP2 = INT( TEMP )
      M1  = M  - M2
      NP1 = NP - NP2
C
      IF ( M1.NE.NP1 ) THEN
         CALL mexErrMsgTxt( 'M - NCON must be equal to P - NMEAS' )
      END IF
C
C  gamma
C
      IF ( mxGetM( PRHS(9) ).NE.1 .OR. mxGetN( PRHS(9) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'GAMMA must be a scalar' )
      ELSE IF ( mxIsNumeric( PRHS(9) ).EQ.0 .OR.
     $          mxIsComplex( PRHS(9) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'GAMMA must be a real scalar' )
      END IF
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(9) ), GAMMA, 1 )
C
      IF ( CONJOB.EQ.'M' ) THEN
C
C     The mu controller case.
C
C  omega
C
         IF ( mxIsNumeric( PRHS(10) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(10) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'OMEGA must be a numeric vector' )
         ELSE IF ( MIN( mxGetM( PRHS(10) ), mxGetN( PRHS(10) ) ).NE.1 )
     $        THEN
            CALL mexErrMsgTxt( 'OMEGA must be a vector' )
         END IF
C
         LENDAT = mxGetM( PRHS(10) )*mxGetN( PRHS(10) )
         IF ( LENDAT.LE.1 ) THEN
            CALL mexErrMsgTxt( 'OMEGA must have at least 2 elements' )
         END IF
C
C  nblock
C
         IF ( mxIsNumeric( PRHS(11) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(11) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'NBLOCK must be a numeric vector' )
         END IF
C
         MNB = mxGetM( PRHS(11) )
         NNB = mxGetN( PRHS(11) )
         MN  = MIN( MNB, NNB )
         MNB = MAX( MNB, NNB )
         NNB = MN
         IF ( NNB.NE.1 ) THEN
            CALL mexErrMsgTxt( 'NBLOCK must be a vector' )
         END IF
C
C  itype
C
         IF ( mxIsNumeric( PRHS(12) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(12) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'ITYPE must be a numeric vector' )
         END IF
C
         MIT = mxGetM( PRHS(12) )
         NIT = mxGetN( PRHS(12) )
         MN  = MIN( MIT, NIT )
         MIT = MAX( MIT, NIT )
         NIT = MN
C
         IF ( NIT.NE.1 ) THEN
            CALL mexErrMsgTxt( 'ITYPE must be a vector' )
         ELSE IF ( MNB.NE.MIT ) THEN
            CALL mexErrMsgTxt
     $                     ( 'ITYPE must have the same size as NBLOCK' )
         END IF
C
C  ord
C
         IF ( mxGetM( PRHS(13) ).NE.1 .OR.
     $        mxGetN( PRHS(13) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'ORD must be a scalar' )
         ELSE IF ( mxIsNumeric( PRHS(13) ).EQ.0 .OR.
     $             mxIsComplex( PRHS(13) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'ORD must be an integer scalar' )
         END IF
C
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(13) ), TEMP, 1 )
         ORD = INT( TEMP )
C
         IF ( ORD.LT.1 ) THEN
            CALL mexErrMsgTxt( 'ORD must be at least 1' )
         ELSE IF ( ORD.GE.LENDAT ) THEN
            WRITE( TEXT, '(''ORD must be less than LENDAT - 1 = '',
     $             I7)' ) LENDAT - 1
            CALL mexErrMsgTxt( TEXT )
         END IF
C
C  qutol
C
         IF ( NRHS.GE.14 ) THEN
            IF ( mxGetM( PRHS(14) ).NE.1 .OR.
     $           mxGetN( PRHS(14) ).NE.1 ) THEN
               CALL mexErrMsgTxt( 'QUTOL must be a scalar' )
            ELSE IF ( mxIsNumeric( PRHS(14) ).EQ.0 .OR.
     $                mxIsComplex( PRHS(14) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'QUTOL must be a real scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(14) ), QUTOL, 1 )
         ELSE
            QUTOL = TWO
         END IF
         IP = 15
      ELSE
         IP = 10
      END IF
C
C  gtol
C
      IF ( NRHS.GE.IP ) THEN
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'GTOL must be a scalar' )
         ELSE IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $             mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'GTOL must be a real scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), GTOL, 1 )
         IP = IP + 1
      ELSE
         GTOL = P01
      END IF
C
C  actol
C
      IF ( NRHS.EQ.IP ) THEN
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'ACTOL must be a scalar' )
         ELSE IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $             mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'ACTOL must be a real scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr(PRHS(IP) ), ACTOL, 1 )
      ELSE
         ACTOL = ZERO
      END IF
C
C     Set the default tolerance.
C
      TOL = SQRT( DLAMCH( 'Epsilon' ) )
C
C Determine the lenghts of working arrays.
C
C     The original system.
C
      LDA = MAX( 1, N )
      LDB = LDA
      LDC = MAX( 1, NP )
      LDD = LDC
C
      IF ( CONJOB.EQ.'M' ) THEN
C
C        The scaling system.
C
         TOTORD = NP1*ORD
C
         F    = MAX( M2, NP2 )
         LDAD = MAX( 1, TOTORD )
         LDBD = LDAD
         LDCD = MAX( 1, NP1 + F )
         LDDD = LDCD
C
C        The extended system.
C
         NE   = N + 2*TOTORD
         LDAE = MAX( 1, NE )
         LDBE = LDAE
         LDCE = LDCD
         LDDE = LDCE
      ELSE
         NE   = N
         LDAE = LDA
      END IF
C
C     The closed-loop system.
C
      N2E  = 2*NE
      LDAC = MAX( 1, N2E )
      LDBC = LDAC
      LDCC = MAX( 1, NP1 )
      LDDC = LDCC
C
C     The controller.
C
      LDAK = LDAE
      LDBK = LDAK
      LDCK = MAX( 1, M2 )
      LDDK = LDCK
C
C     LBWORK
C
C     ..SB10AD..
      LBWORK = N2E
C
C     LIWORK
C
C     ..SB10AD..
      LI1 = MAX( 2*MAX( NE, M - M2, NP - NP2, M2, NP2 ), NE*NE )
C
      IF ( CONJOB.EQ.'M' ) THEN
C        ..SB10MD..
         LI2 = MAX( N2E, 4*MNB - 2, NP1 )
         IF ( QUTOL.GE.ZERO )
     $      LI2 = MAX( LI2, 2*ORD + 1  )
C        ..AB07ND..
         LI3 = 2*M
      ELSE
         LI2 = 0
         LI3 = 0
      END IF
C
C     ..AB04MD..
      LI4 = NE
C
      LIWORK = MAX( LI1, LI2, LI3, LI4 )
C
C     LDWORK
C
C     ..AB04MD..
      LD1 = LDAK
C
C     ..SB10AD..
      NP11 = NP1 - M2
      M11  = M1 - NP2
      LW1 = NE*M + NP*NE + NP*M + M2*M2 + NP2*NP2
      LW2 = MAX( ( NE + NP1 + 1 )*( NE + M2 ) +
     $             MAX( 3*( NE + M2 ) + NE + NP1, 5*( NE + M2 ) ),
     $           ( NE + NP2 )*( NE + M1 + 1 ) +
     $             MAX( 3*( NE + NP2 ) + NE + M1, 5*( NE + NP2 ) ),
     $           M2 + NP1*NP1 + MAX( NP1*MAX( NE, M1 ), 3*M2 + NP1,
     $                               5*M2 ),
     $           NP2 + M1*M1 +  MAX( MAX( NE, NP1 )*M1, 3*NP2 + M1,
     $                               5*NP2 ) )
      LW3 = MAX( NP11*M1 + MAX( 4*MIN( NP11, M1 ) + MAX( NP11, M1 ),
     $                          6*MIN( NP11, M1 ) ),
     $           NP1*M11 + MAX( 4*MIN( NP1, M11 ) + MAX( NP1, M11 ),
     $                          6*MIN( NP1, M11 ) ) )
      LW4 = 2*M*M + NP*NP + 2*M*NE + M*NP + 2*NE*NP
      LW5 = 2*NE*NE + M*NE + NE*NP
      LW6 = MAX( M*M + MAX( 2*M1, 3*NE*NE +
     $                      MAX( NE*M, 10*NE*NE + 12*NE + 5 ) ),
     $           NP*NP + MAX( 2*NP1, 3*NE*NE +
     $                        MAX( NE*NP, 10*NE*NE + 12*NE + 5 ) ) )
      LW7 = M2*NP2 + NP2*NP2 + M2*M2 +
     $      MAX( NP11*NP11 + MAX( 2*NP11, ( NP11 + M11 )*NP2 ),
     $           M11*M11 + MAX( 2*M11, M11*M2 ), 3*NE,
     $           NE*( 2*NP2 + M2 ) +
     $           MAX( 2*NE*M2, M2*NP2 +
     $                         MAX( M2*M2 + 3*M2, NP2*( 2*NP2 +
     $                              M2 + MAX( NP2, NE ) ) ) ) )
      LD2 = LW1 + MAX( 1, LW2, LW3, LW4, LW5 + MAX( LW6, LW7 ) )
C
      IF ( CONJOB.EQ.'M' ) THEN
C
C        ..SB10MD..
         MN  = MIN( 2*LENDAT, 2*ORD + 1 )
         LWA = NP1*LENDAT + 2*MNB + NP1 - 1
         LWB = LENDAT*( NP1 + 2 ) + ORD*( ORD + 2 ) + 1
         LW1 = 2*LENDAT + 4*HNPTS
         LW2 =   LENDAT + 6*HNPTS
         LW3 = 2*LENDAT*( 2*ORD + 1 ) + MAX( 2*LENDAT, 2*ORD + 1 ) +
     $                                  MAX( MN + 6*ORD + 4, 2*MN + 1 )
         LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) )
C
         LD3 = LWA + MAX( N2E + MAX( N2E, NP1 - 1 ),
     $                    2*NP1*NP1*MNB - NP1*NP1 + 9*MNB*MNB +
     $                      NP1*MNB + 11*NP1 + 33*MNB - 11 )
         IF ( QUTOL.GE.ZERO ) THEN
            LD4 = LWB + MAX( LW1, LW2, LW3, LW4 )
         ELSE
            LD4 = 0
         END IF
C        .. AB05MD..
         LD4 = MAX( LD4, MAX( M, NP )*MAX( N + TOTORD, M, NP ) )
C        .. AB07ND..
         LD4 = MAX( LD4, 4*M )
      ELSE
         LD3 = 0
         LD4 = 0
      END IF
C
      LDWORK = MAX( LD1, LD2, LD3, LD4 )
C
C     LZWORK
C
      IF ( CONJOB.EQ.'M' ) THEN
C        ..SB10MD..
         LZM = MAX( NP1*NP1 + N2E*NP1 + N2E*N2E + 2*N2E,
     $              6*NP1*NP1*MNB + 13*NP1*NP1 + 6*MNB + 6*NP1 - 3 )
         IF ( QUTOL.GE.ZERO ) THEN
            LZD = MAX( LENDAT*( 2*ORD + 3 ), ORD*ORD + 3*ORD + 1 )
         ELSE
            LZD = 0
         END IF
         LZWORK = MAX( LZM, LZD )
      END IF
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE ( A(LDA*N), AC(LDAC*N2E), AK(LDAK*NE),
     $           B(LDB*M), BC(LDBC*M1),  BK(LDBK*NP2), BWORK(LBWORK),
     $           C(LDC*N), CC(LDCC*N2E), CK(LDCK*NE),
     $           D(LDD*M), DC(LDDC*M1),  DK(LDDK*NP2), DWORK(LDWORK),
     $           IWORK(LIWORK) )
C
      IF ( CONJOB.EQ.'M' ) THEN
         ALLOCATE ( AD(LDAD*TOTORD), AE(LDAE*NE),     AKB(LDAK*NE),
     $              BD(LDBD*(M1+F)), BE(LDBE*(M1+F)), BKB(LDBK*NP2),
     $              CD(LDCD*TOTORD), CE(LDCE*NE),     CKB(LDCK*NE),
     $              DD(LDDD*(M1+F)), DE(LDDE*(M1+F)), DKB(LDDK*NP2),
     $              ITYPE(MNB), MJU(LENDAT), NBLOCK(MNB), OMEGA(LENDAT),
     $              PMJU(LENDAT), RITYPE(MNB), RNBLCK(MNB),
     $              ZWORK(LZWORK) )
      END IF
C
C Copy right hand side arguments to local arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), A, N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), B, N*M )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), C, NP*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(6) ), D, NP*M )
C
      IF ( CONJOB.EQ.'M' ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(10) ), OMEGA, LENDAT )
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(11) ), RNBLCK, MNB )
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(12) ), RITYPE, MNB )
C
         DO 10 I = 1, MNB
            NBLOCK(I) = INT( RNBLCK(I) )
            ITYPE(I)  = INT( RITYPE(I) )
   10    CONTINUE
      END IF
C
C Do the actual computations.
C
C     Transform to continuous-case, if needed.
C
      IF ( DISCR.EQ.1 ) THEN
         CALL AB04MD( 'D', N, M, NP, ONE, ONE, A, LDA, B, LDB, C, LDC,
     $                D, LDD, IWORK, DWORK, LDWORK, INFO )
C
         IF ( INFO.NE.0 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM AB04MD'')' )
     $             INFO
            GOTO 60
         END IF
C
         IF ( CONJOB.EQ.'M' ) THEN
C
            DO 20 I = 1, LENDAT
               OMEGA(I) = SQRT( ( ONE - COS( OMEGA(I) ) ) /
     $                          ( ONE + COS( OMEGA(I) ) + TOL ) )
   20       CONTINUE
C
         END IF
C
      END IF
C
C     Set parameters for the first K step.
C
      N2E  = 2*N
      NE   = N
      NEB  = N
      ITER = 1
C
C     First K step - makes use of the original system.
C
      CALL SB10AD( JOB, N, M, NP, M2, NP2, GAMMA, A, LDA, B, LDB, C,
     $             LDC, D, LDD, AK, LDA, BK, LDB, CK, LDCK, DK, LDDK,
     $             AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, RCOND, GTOL,
     $             ACTOL, IWORK, LIWORK, DWORK, LDWORK, BWORK, LBWORK,
     $             INFO )
C
      IF ( INFO.NE.0 ) THEN
         WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM SB10AD'')' )
     $          INFO
         GOTO 60
      END IF
C
C     Skip the D step if H_inf controller only desired.
C
      IF ( CONJOB.EQ.'H' )
     $   GOTO 50
C
      PMPEAK = GAMMA + P01
C
C     Start the iteration process
C     --------- D step -------------------------------------------------
C
   30 CONTINUE
C
         CALL SB10MD( N2E, NP1, LENDAT, F, ORD, MNB, NBLOCK, ITYPE,
     $                QUTOL, AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC,
     $                OMEGA, TOTORD, AD, LDAD, BD, LDBD, CD, LDCD, DD,
     $                LDDD, MJU, IWORK, LIWORK, DWORK, LDWORK, ZWORK,
     $                LZWORK, INFO )
C
         IF ( INFO.NE.0 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM SB10MD'')' )
     $             INFO
            GOTO 60
         END IF
C
C        Check mu.
C
         MUPEAK = ZERO
C
         DO 40 I = 1, LENDAT
            MUPEAK = MAX( MUPEAK, MJU(I) )
   40    CONTINUE
C
         IF ( MUPEAK.GT.PMPEAK ) THEN
            IF ( ITER.NE.1 )
     $         CALL DCOPY( LENDAT, PMJU, 1, MJU, 1 )
            GOTO 50
         ELSE
C
C           Save the best controller.
C
            PMPEAK = MUPEAK
            ITERB  = ITER
            NEB    = NE
C
            CALL DCOPY( LENDAT, MJU, 1, PMJU, 1 )
            IF ( ITER.NE.1 ) THEN
               CALL DCOPY( NE*NE,  AKB, 1, AK, 1 )
               CALL DCOPY( NE*NP2, BKB, 1, BK, 1 )
               CALL DCOPY( M2*NE,  CKB, 1, CK, 1 )
               CALL DCOPY( M2*NP2, DKB, 1, DK, 1 )
            END IF
         END IF
C
         ITER = ITER + 1
         IF ( ITER.GT.MAXIT )
     $      GOTO 50
C
C        Dl*P.
C
         CALL AB05MD( 'U', 'N', N, M, NP, TOTORD, NP, A, LDA, B, LDB,
     $                C, LDC, D, LDD, AD, LDAD, BD, LDBD, CD, LDCD, DD,
     $                LDDD, NTEMP, AE, LDAE, BE, LDBE, CE, LDCE, DE,
     $                LDDE, DWORK, LDWORK, INFO )
C
C        inv(Dr).
C
         CALL AB07ND( TOTORD, M, AD, LDAD, BD, LDBD, CD, LDCD, DD, LDDD,
     $                TEMP, IWORK, DWORK, LDWORK, INFO )
C
         IF ( INFO.NE.0 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM AB07ND'')' )
     $             INFO
            GOTO 60
         END IF
C
C        Dl*P*inv(Dr).
C
         CALL AB05MD( 'U', 'O', TOTORD, M, M, NTEMP, NP, AD, LDAD, BD,
     $                LDBD, CD, LDCD, DD, LDDD, AE, LDAE, BE, LDBE,
     $                CE, LDCE, DE, LDDE, NE, AE, LDAE, BE, LDBE, CE,
     $                LDCE, DE, LDDE, DWORK, LDWORK, INFO )
         N2E  = 2*NE
         LDAK = MAX( 1, NE )
         LDBK = LDAK
C
C        --------- K step ----------------------------------------------
C
         CALL SB10AD( JOB, NE, M, NP, M2, NP2, GAMMA, AE, LDAE, BE,
     $                LDBE, CE, LDCE, DE, LDDE, AKB, LDAK, BKB, LDBK,
     $                CKB, LDCK, DKB, LDDK, AC, LDAC, BC, LDBC, CC,
     $                LDCC, DC, LDDC, RCOND( 4*ITER-3 ), GTOL, ACTOL,
     $                IWORK, LIWORK, DWORK, LDWORK, BWORK, LBWORK,
     $                INFO )
C
         IF ( INFO.NE.0 ) THEN
            INFO = 0
            GOTO 50
         END IF
C
      GOTO 30
C
C     ---- End of the mu synthesis -------------------------------------
C
   50 CONTINUE
C
C     Transform back to discrete time if needed.
C
      IF ( DISCR.EQ.1 ) THEN
         CALL AB04MD( 'C', NEB, NP2, M2, ONE, ONE, AK, LDAK, BK, LDBK,
     $                CK, LDCK, DK, LDDK, IWORK, DWORK, LDWORK, INFO )
C
         IF ( INFO.NE.0 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM AB04MD'')' )
     $             INFO
            GOTO 60
         END IF
      END IF
C
C Copy output to MATLAB workspace.
C
      PLHS(1) = mxCreateDoubleMatrix( NEB, NEB, 0 )
      PLHS(2) = mxCreateDoubleMatrix( NEB, NP2, 0 )
      PLHS(3) = mxCreateDoubleMatrix( M2,  NEB, 0 )
      PLHS(4) = mxCreateDoubleMatrix( M2,  NP2, 0 )
      CALL mxCopyReal8ToPtr( AK, mxGetPr( PLHS(1) ), NEB*NEB )
      CALL mxCopyReal8ToPtr( BK, mxGetPr( PLHS(2) ), NEB*NP2 )
      CALL mxCopyReal8ToPtr( CK, mxGetPr( PLHS(3) ), M2*NEB )
      CALL mxCopyReal8ToPtr( DK, mxGetPr( PLHS(4) ), M2*NP2 )
C
      IF ( NLHS.GE.5 ) THEN
         IF ( CONJOB.EQ.'M' ) THEN
C           mu
            PLHS(5) = mxCreateDoubleMatrix( LENDAT, 1, 0 )
            CALL mxCopyReal8ToPtr( MJU, mxGetPr( PLHS(5) ), LENDAT )
            IF ( NLHS.GE.6 ) THEN
               PLHS(6) = mxCreateDoubleMatrix( ITERB*4, 1, 0 )
               CALL mxCopyReal8ToPtr( RCOND, mxGetPr( PLHS(6) ),
     $                                ITERB*4 )
            END IF
         ELSE
C           H_inf
            PLHS(5) = mxCreateDoubleMatrix( 1, 1, 0 )
            CALL mxCopyReal8ToPtr( GAMMA, mxGetPr( PLHS(5) ), 1 )
            IF ( NLHS.GE.6 ) THEN
               PLHS(6) = mxCreateDoubleMatrix( 4, 1, 0 )
               CALL mxCopyReal8ToPtr( RCOND, mxGetPr( PLHS(6) ), 4 )
            END IF
         END IF
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
   60 CONTINUE
C
      DEALLOCATE ( A, AC, AK, B, BC, BK, BWORK, C, CC, CK, D, DC, DK,
     $             DWORK, IWORK )
C
      IF ( CONJOB.EQ.'M' )
     $   DEALLOCATE ( AD, AE, AKB, BD, BE, BKB, CD, CE, CKB, DD, DE,
     $                DKB, ITYPE, MJU, NBLOCK, OMEGA, PMJU, RITYPE,
     $                RNBLCK, ZWORK )
C
C Error and warning handling ..
C
      IF ( INFO.NE.0 )
     $   CALL mexErrMsgTxt( TEXT )
C
      RETURN
C
C *** Last line of MUHOPT ***
      END


module triples
  implicit none

  integer :: max_peri, prim, total
  integer :: u(9,3) = reshape((/ 1, -2, 2,  2, -1, 2,  2, -2, 3, &
                                 1,  2, 2,  2,  1, 2,  2,  2, 3, &
                                -1,  2, 2, -2,  1, 2, -2,  2, 3 /), &
                                (/ 9, 3 /))

contains

recursive subroutine new_tri(in)
  integer, intent(in) :: in(:)
  integer :: i
  integer :: t(3), p

  p = sum(in)
  if (p > max_peri) return

  prim = prim + 1
  total = total + max_peri / p
  do i = 1, 3
    t(1) = sum(u(1:3, i) * in)
    t(2) = sum(u(4:6, i) * in)
    t(3) = sum(u(7:9, i) * in)
    call new_tri(t);
  end do
end subroutine new_tri
end module triples

program Pythagorean
  use triples
  implicit none

  integer :: seed(3) = (/ 3, 4, 5 /)

  max_peri = 10
  do
    total = 0
    prim = 0
    call new_tri(seed)
    write(*, "(a, i10, 2(i10, a))") "Up to", max_peri, total, " triples",  prim, " primitives"
    if(max_peri == 100000000) exit
    max_peri = max_peri * 10
  end do
end program Pythagorean


module condensation

    implicit none

    private
    public get_large_scale_condensation_tendencies

    ! Constants for large-scale condensation
    real, parameter :: trlsc  = 4.0  !! Relaxation time (in hours) for specific humidity
    real, parameter :: rhlsc  = 0.9  !! Maximum relative humidity threshold (at sigma=1)
    real, parameter :: drhlsc = 0.1  !! Vertical range of relative humidity threshold
    real, parameter :: rhblsc = 0.95 !! Relative humidity threshold for boundary layer

contains
    subroutine get_large_scale_condensation_tendencies(psa, qa, qsat, itop, &
                                       & ngp, nlev, sig, &
                                       & precls, dtlsc, dqlsc)
        use physical_constants, only: p0, cp, alhc, grav
        use utils, only: get_sigma_thicknesses

        real, intent(in) :: psa(ngp)
        real, intent(in) :: qa(ngp,nlev)
        real, intent(in) :: qsat(ngp,nlev)
        integer, intent(inout) :: itop(ngp)
        real, intent(out) :: precls(ngp)
        integer, intent(in) :: ngp
        integer, intent(in) :: nlev
        real, intent(in) :: sig(nlev)
        real, intent(out) :: dtlsc(ngp,nlev)
        real, intent(out) :: dqlsc(ngp,nlev)

        real :: psa2(ngp), dqa, tfact, sig2, rtlsc, rhref, qsmax, prg, pfact, dqmax
        real :: dsig(nlev)
        integer :: j, k

        ! 1. Initialization
        dsig = get_sigma_thicknesses(sig)
        qsmax = 10.0

        rtlsc = 1.0/(trlsc*3600.0)
        tfact = alhc/cp
        prg = p0/grav

        do j = 1, ngp
            dtlsc(j,1) = 0.0
            dqlsc(j,1) = 0.0
            precls(j)  = 0.0
            psa2(j)    = psa(j)*psa(j)
        end do

        ! 2. Tendencies of temperature and moisture
        !    NB. A maximum heating rate is imposed to avoid
        !        grid-point-storm instability
        do k = 2, nlev
            sig2 = sig(k)*sig(k)
            rhref = rhlsc + drhlsc*(sig2 - 1.0)
            if (k == nlev) rhref = max(rhref, rhblsc)
            dqmax = qsmax*sig2*rtlsc

            do j = 1, ngp
                dqa = rhref*qsat(j,k) - qa(j,k)
                if (dqa < 0.0) then
                    itop(j)    = min(k, itop(j))
                    dqlsc(j,k) = dqa*rtlsc
                    dtlsc(j,k) = tfact*min(-dqlsc(j,k), dqmax*psa2(j))
                else
                    dqlsc(j,k) = 0.0
                    dtlsc(j,k) = 0.0
                endif
            end do
        end do

        ! 3. Large-scale precipitation
        do k = 2, nlev
            pfact = dsig(k)*prg
            do j = 1, ngp
                precls(j) = precls(j) - pfact*dqlsc(j,k)
            end do
        end do

        do j = 1, ngp
            precls(j) = precls(j)*psa(j)
        end do
    end subroutine get_large_scale_condensation_tendencies
end module condensation


C
C     The Chebyquad test problem (Fletcher, 1965) for N = 2,4,6 and 8,
C     with NPT = 2N+1.
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(10),W(10000)
      IPRINT=2
      MAXFUN=5000
      RHOEND=1.0D-6
      DO 30 N=2,8,2
      NPT=2*N+1
      DO 10 I=1,N
   10 X(I)=DFLOAT(I)/DFLOAT(N+1)
      RHOBEG=0.2D0*X(1)
      PRINT 20, N,NPT
   20 FORMAT (//4X,'Results with N =',I2,' and NPT =',I3)
      CALL NEWUOA (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,W)
   30 CONTINUE
      STOP
      END


!*==sladiv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLADIV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLADIV( A, B, C, D, P, Q )
!
!       .. Scalar Arguments ..
!       REAL               A, B, C, D, P, Q
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLADIV performs complex division in  real arithmetic
!>
!>                       a + i*b
!>            p + i*q = ---------
!>                       c + i*d
!>
!> The algorithm is due to Michael Baudin and Robert L. Smith
!> and can be found in the paper
!> "A Robust Complex Division in Scilab"
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] A
!> \verbatim
!>          A is REAL
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is REAL
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is REAL
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is REAL
!>          The scalars a, b, c, and d in the above expression.
!> \endverbatim
!>
!> \param[out] P
!> \verbatim
!>          P is REAL
!> \endverbatim
!>
!> \param[out] Q
!> \verbatim
!>          Q is REAL
!>          The scalars p and q in the above expression.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date January 2013
!
!> \ingroup realOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE SLADIV(A,B,C,D,P,Q)
      IMPLICIT NONE
!*--SLADIV95
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     January 2013
!
!     .. Scalar Arguments ..
      REAL A , B , C , D , P , Q
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL BS
      PARAMETER (BS=2.0E0)
      REAL HALF
      PARAMETER (HALF=0.5E0)
      REAL TWO
      PARAMETER (TWO=2.0E0)
!
!     .. Local Scalars ..
      REAL aa , bb , cc , dd , ab , cd , s , ov , un , be , eps
!     ..
!     .. External Functions ..
      REAL SLAMCH
      EXTERNAL SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL SLADIV1
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX
!     ..
!     .. Executable Statements ..
!
      aa = A
      bb = B
      cc = C
      dd = D
      ab = MAX(ABS(A),ABS(B))
      cd = MAX(ABS(C),ABS(D))
      s = 1.0E0

      ov = SLAMCH('Overflow threshold')
      un = SLAMCH('Safe minimum')
      eps = SLAMCH('Epsilon')
      be = BS/(eps*eps)

      IF ( ab>=HALF*ov ) THEN
         aa = HALF*aa
         bb = HALF*bb
         s = TWO*s
      ENDIF
      IF ( cd>=HALF*ov ) THEN
         cc = HALF*cc
         dd = HALF*dd
         s = HALF*s
      ENDIF
      IF ( ab<=un*BS/eps ) THEN
         aa = aa*be
         bb = bb*be
         s = s/be
      ENDIF
      IF ( cd<=un*BS/eps ) THEN
         cc = cc*be
         dd = dd*be
         s = s*be
      ENDIF
      IF ( ABS(D)<=ABS(C) ) THEN
         CALL SLADIV1(aa,bb,cc,dd,P,Q)
      ELSE
         CALL SLADIV1(bb,aa,dd,cc,P,Q)
         Q = -Q
      ENDIF
      P = P*s
      Q = Q*s
!
!
!     End of SLADIV
!
      END SUBROUTINE SLADIV
!*==sladiv1.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022

!> \ingroup realOTHERauxiliary

      SUBROUTINE SLADIV1(A,B,C,D,P,Q)
      IMPLICIT NONE
!*--SLADIV1184
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     January 2013
!
!     .. Scalar Arguments ..
      REAL A , B , C , D , P , Q
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE
      PARAMETER (ONE=1.0E0)
!
!     .. Local Scalars ..
      REAL r , t
!     ..
!     .. External Functions ..
      REAL SLADIV2
      EXTERNAL SLADIV2
!     ..
!     .. Executable Statements ..
!
      r = D/C
      t = ONE/(C+D*r)
      P = SLADIV2(A,B,C,D,r,t)
      A = -A
      Q = SLADIV2(B,A,C,D,r,t)
!
!
!     End of SLADIV1
!
      END SUBROUTINE SLADIV1
!*==sladiv2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022

!> \ingroup realOTHERauxiliary

      REAL FUNCTION SLADIV2(A,B,C,D,R,T)
      IMPLICIT NONE
!*--SLADIV2226
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     January 2013
!
!     .. Scalar Arguments ..
      REAL A , B , C , D , R , T
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E0)
!
!     .. Local Scalars ..
      REAL br
!     ..
!     .. Executable Statements ..
!
      IF ( R/=ZERO ) THEN
         br = B*R
         IF ( br/=ZERO ) THEN
            SLADIV2 = (A+br)*T
         ELSE
            SLADIV2 = A*T + (B*T)*R
         ENDIF
      ELSE
         SLADIV2 = (A+D*(B/C))*T
      ENDIF
!
!
!     End of SLADIV
!
      END FUNCTION SLADIV2


      SUBROUTINE slNUT (DATE, RMATN)
*+
*     - - - -
*      N U T
*     - - - -
*
*  Form the matrix of nutation for a given date - Shirai & Fukushima
*  2001 theory (double precision)
*
*  Reference:
*     Shirai, T. & Fukushima, T., Astron.J. 121, 3270-3283 (2001).
*
*  Given:
*     DATE    d          TDB (loosely ET) as Modified Julian Date
*                                           (=JD-2400000.5)
*  Returned:
*     RMATN   d(3,3)     nutation matrix
*
*  Notes:
*
*  1  The matrix is in the sense  v(true) = rmatn * v(mean) .
*     where v(true) is the star vector relative to the true equator and
*     equinox of date and v(mean) is the star vector relative to the
*     mean equator and equinox of date.
*
*  2  The matrix represents forced nutation (but not free core
*     nutation) plus corrections to the IAU~1976 precession model.
*
*  3  Earth attitude predictions made by combining the present nutation
*     matrix with IAU~1976 precession are accurate to 1~mas (with
*     respect to the ICRS) for a few decades around 2000.
*
*  4  The distinction between the required TDB and TT is always
*     negligible.  Moreover, for all but the most critical applications
*     UTC is adequate.
*
*  Called:   slNUTC, slDEUL
*
*  Last revision:   1 December 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE,RMATN(3,3)

      DOUBLE PRECISION DPSI,DEPS,EPS0

*  Nutation components and mean obliquity
      CALL slNUTC(DATE,DPSI,DEPS,EPS0)

*  Rotation matrix
      CALL slDEUL('XZX',EPS0,-DPSI,-(EPS0+DEPS),RMATN)

      END


MODULE m_force_a3
CONTAINS
  SUBROUTINE force_a3(atoms,sym,sphhar,input,rho,vr,force)
    ! ************************************************************
    ! Hellman-Feynman force contribution a la Rici et al.
    ! ************************************************************
    !
    USE m_intgr, ONLY : intgr3
    USE m_constants
    USE m_types
    IMPLICIT NONE
    TYPE(t_input),INTENT(IN)   :: input
    TYPE(t_sphhar),INTENT(IN)   :: sphhar
    TYPE(t_atoms),INTENT(IN)   :: atoms
    TYPE(t_sym),INTENT(IN)     :: sym
    !     .. Array Arguments ..
    REAL,    INTENT (IN) ::  vr(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins)
    REAL,    INTENT (IN) :: rho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins)
    REAL,    INTENT (INOUT) :: force(3,atoms%ntype,input%jspins)
    !     ..
    !     .. Local Scalars ..
    COMPLEX,PARAMETER:: czero=(0.0,0.0)
    REAL a3_1,a3_2,s34,s38,w
    INTEGER i,ir,jsp,lh,lindex,mem,mindex,n,nd,na
    !     ..
    !     .. Local Arrays ..
    COMPLEX forc_a3(3),grd1(3,-1:1),gv(3)
    REAL rhoaux(atoms%jmtd)
    !     ..
    !     set components of gradient in terms of Ylms
    !
    s34 = SQRT(3.0/ (4.0*pi_const))
    s38 = SQRT(3.0/ (8.0*pi_const))
    grd1(1,0) = czero
    grd1(2,0) = czero
    grd1(3,0) = CMPLX(s34,0.0)
    grd1(1,-1) = CMPLX(s38,0.0)
    grd1(2,-1) = CMPLX(0.0,-s38)
    grd1(3,-1) = czero
    grd1(1,1) = CMPLX(-s38,0.0)
    grd1(2,1) = CMPLX(0.0,-s38)
    grd1(3,1) = czero
    !
    WRITE  (oUnit,*)
    spin: DO jsp = 1,input%jspins
       na = 1
       DO n = 1,atoms%ntype
          IF (atoms%l_geo(n)) THEN

             DO i = 1,3
                forc_a3(i) = czero
             END DO
             !
             nd = sym%ntypsy(na)
             !
             lat_har: DO lh = 1,sphhar%nlh(nd)
                lindex = sphhar%llh(lh,nd)
                IF (lindex.GT.1) EXIT
                DO i = 1,3
                   gv(i) = czero
                END DO
                !    sum over all m for particular symm. harmonic
                DO mem = 1,sphhar%nmem(lh,nd)
                   mindex = sphhar%mlh(mem,lh,nd)
                   DO i = 1,3
                      gv(i) = gv(i) + sphhar%clnu(mem,lh,nd)*grd1(i,mindex)
                   END DO
                END DO
                DO ir = 1,atoms%jri(n)
                   rhoaux(ir) = rho(ir,lh,n,jsp)/ (atoms%rmsh(ir,n)**2)*&
                        &                         (1.0- (atoms%rmsh(ir,n)/atoms%rmt(n))**3)
                END DO
                CALL intgr3(rhoaux,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),w)
                a3_1 = 4.0*pi_const/3.0*w
                !+Gu
                a3_2 = vr(atoms%jri(n),lh,n,jsp)/(input%jspins*atoms%rmt(n))
                !-Gu
                DO i = 1,3
                   forc_a3(i) = forc_a3(i) + (a3_1+a3_2)*gv(i)*atoms%zatom(n)
                END DO
             ENDDO lat_har

             DO i = 1,3
                force(i,n,jsp) = force(i,n,jsp) + REAL(forc_a3(i))
             END DO
             !
             !     write result
             WRITE (oUnit,FMT=8010) n
             WRITE (oUnit,FMT=8020) (forc_a3(i),i=1,3)
8010         FORMAT (' FORCES: EQUATION A3 FOR ATOM TYPE',i4)
8020         FORMAT (' FX_A3=',2f10.6,' FY_A3=',2f10.6,' FZ_A3=',2f10.6)

          ENDIF               ! atoms%l_geo(n) = .true.
          na = na + atoms%neq(n)
       ENDDO

    ENDDO spin

  END SUBROUTINE force_a3
END MODULE m_force_a3