cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc             mnsphe : sphere test program                           cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real teta(192),phi(192),r(192),w(192),tp(30),tt(30),c(300),
     * p(9),t(9),f(81),wrk1(12000),wrk2(72)
      integer iwrk(300)
      real eps,fp,pi,pi2,pi4,s,scale,scp,sct,ai
      integer i,ier,iopt,j,kwrk,lwrk1,lwrk2,l1,l2,l,m,np,npest,nt,ntest
     * ,is,i1,i2,nc,ntt,npp
      real atan,testsp
c  set constants
      pi4 = atan(0.1e+01)
      pi = pi4*4
      pi2 = pi+pi
      scale = pi4/0.45e+02
c  we fetch the number of data points.
      m = 192
c  we fetch and print the latitude - longitude coordinates of the data
c  points (in degrees).
      write(6,900)
      write(6,905)
      l2 = 0
      do 10 i=1,48
         l1 = l2+1
         l2 = l2+4
         read(5,910) (teta(l),phi(l),l=l1,l2)
         write(6,915)(teta(l),phi(l),l=l1,l2)
  10  continue
c  we set up the weights, scale into radians the latitude-longitude
c  coordinates and calculate the function values.
      do 20 i=1,m
         w(i) = 0.1e+01
         teta(i) = teta(i)*scale
         phi(i) = phi(i)*scale
         if(teta(i).gt.pi) teta(i) = pi
         if(phi(i).gt.pi2) phi(i) = pi2
         r(i) = testsp(teta(i),phi(i))
  20  continue
c  we set up the coordinates of the grid points for the evaluation of
c  the spline approximations.
      sct = pi/8
      scp = pi2/8
      do 30 i=1,8
         ai = i-1
         t(i) = ai*sct
         p(i) = ai*scp
  30  continue
      t(9) = pi
      p(9) = pi2
c we set up the dimension information
      ntest = 15
      npest = 19
      lwrk1 = 12000
      lwrk2 = 72
      kwrk = 300
c  we choose a value for eps
      eps = 0.1e-05
c  main loop for the different spline approximations
      do 300 is=1,4
        go to (110,120,130,140),is
c  we start computing the least-squares constrained polynomial (large s)
 110    iopt = 0
        s = 500.
        go to 200
c  iopt = 1 from the second call on.
 120    iopt = 1
        s = 135.
        go to 200
 130    s = 15.
        go to 200
c  a least-squares spherical spline with specified knots.
 140    iopt = -1
c  we set up the number of knots.
        nt = 11
        np = 15
c  we set up the position of the interior knots of the spline.
        ntt = nt-8
        do 150 i=1,ntt
          ai = i
          j = i+4
          tt(j) = ai*pi4
 150    continue
        npp = np-8
        do 160 i=1,npp
          ai = i
          j = i+4
          tp(j) = ai*pi4
 160    continue
c  determination of the spline approximation.
 200    call sphere(iopt,m,teta,phi,r,w,s,ntest,npest,eps,nt,tt,
     *   np,tp,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
c  printing of the fitting results.
        if(iopt.ge.0) go to 210
        write(6,920)
        go to 220
 210    write(6,925)
        write(6,930) s
 220    write(6,935) fp,ier
        write(6,940) nt
        write(6,945)
        write(6,950) (tt(i),i=1,nt)
        write(6,955) np
        write(6,945)
        write(6,950) (tp(i),i=1,np)
        nc = (nt-4)*(np-4)
        write(6,960)
        write(6,965) (c(i),i=1,nc)
c  evaluation of the spline approximation.
        call bispev(tt,nt,tp,np,c,3,3,t,9,p,9,f,wrk2,lwrk2,
     *   iwrk,kwrk,ier)
        write(6,970) (p(i),i=1,9)
        write(6,975)
        i2 = 0
        do 230 i=1,9
          i1 = i2+1
          i2 = i2+9
          write(6,980) t(i),(f(j),j=i1,i2)
 230    continue
 300  continue
      stop
c  format statements.
 900  format(55h1latitude-longitude values of the data points (degrees))
 905  format(1h0,4(3x,10hteta   phi,3x))
 910  format(8f6.0)
 915  format(1h ,4(3x,f4.0,2x,f4.0,3x))
 920  format(50h0least-squares spline approximation on the sphere.)
 925  format(32h0smoothing spline on the sphere.)
 930  format(20h smoothing factor s=,f9.0)
 935  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i3)
 940  format(1x,45htotal number of knots in the teta-direction =,i3)
 945  format(1x,22hposition of the knots )
 950  format(5x,8f8.4)
 955  format(1x,44htotal number of knots in the phi-direction =,i3)
 960  format(23h0b-spline coefficients )
 965  format(5x,8f9.4)
 970  format(9h      phi,9f7.3)
 975  format(6h  teta)
 980  format(1h ,f6.3,2x,9f7.3)
      end
      real function testsp(v,u)
c function program testsp calculates the value of a test function for
c the sphere package.
c ..
      real cos,cu,cv,rad1,rad2,rad3,sin,sqrt,su,sv,u,v
      cu = cos(u)
      cv = cos(v)
      su = sin(u)
      sv = sin(v)
      rad1 = (cu*sv*0.2)**2+(su*sv)**2+(cv*0.5)**2
      rad2 = (cu*sv)**2+(su*sv*0.5)**2+(cv*0.2)**2
      rad3 = (cu*sv*0.5)**2+(su*sv*0.2)**2+cv**2
      testsp = 1./sqrt(rad1) + 1./sqrt(rad2) + 1./sqrt(rad3)
      return
      end


*DECK DCSEVL
      DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N)
C***BEGIN PROLOGUE  DCSEVL
C***PURPOSE  Evaluate a Chebyshev series.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      DOUBLE PRECISION (CSEVL-S, DCSEVL-D)
C***KEYWORDS  CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Evaluate the N-term Chebyshev series CS at X.  Adapted from
C  a method presented in the paper by Broucke referenced below.
C
C       Input Arguments --
C  X    value at which the series is to be evaluated.
C  CS   array of N terms of a Chebyshev series.  In evaluating
C       CS, only half the first coefficient is summed.
C  N    number of terms in array CS.
C
C***REFERENCES  R. Broucke, Ten subroutines for the manipulation of
C                 Chebyshev series, Algorithm 446, Communications of
C                 the A.C.M. 16, (1973) pp. 254-256.
C               L. Fox and I. B. Parker, Chebyshev Polynomials in
C                 Numerical Analysis, Oxford University Press, 1968,
C                 page 56.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900329  Prologued revised extensively and code rewritten to allow
C           X to be slightly outside interval (-1,+1).  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DCSEVL
      DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH
      LOGICAL FIRST
      SAVE FIRST, ONEPL
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DCSEVL
      IF (FIRST) ONEPL = 1.0D0 + D1MACH(4)
      FIRST = .FALSE.
      IF (N .LT. 1) CALL XERMSG ('SLATEC', 'DCSEVL',
     +   'NUMBER OF TERMS .LE. 0', 2, 2)
      IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'DCSEVL',
     +   'NUMBER OF TERMS .GT. 1000', 3, 2)
      IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'DCSEVL',
     +   'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1)
C
      B1 = 0.0D0
      B0 = 0.0D0
      TWOX = 2.0D0*X
      DO 10 I = 1,N
         B2 = B1
         B1 = B0
         NI = N + 1 - I
         B0 = TWOX*B1 - B2 + CS(NI)
   10 CONTINUE
C
      DCSEVL = 0.5D0*(B0-B2)
C
      RETURN
      END


!234567890
      subroutine spline(f,x,n,t,d2f)
!     constructs a spline assuming periodic boundary conditions
!     input: coordinate x, function value f, number of points n, period t
!     output: second derivatives d2f
      implicit none
      integer n,nm
      double precision x(n),f(n),d2f(n),t
      integer ii,jj,iperm(n),nperm
      double precision cmat(n,n)

      do ii=1,n
      do jj=1,n
        cmat(ii,jj)=0.d0
      enddo
      enddo
      d2f(1)=(f(2)-f(1))/(x(2)-x(1)) &
&           -(f(1)-f(n))/(x(1)-x(n)+t)
      cmat(1,n)=(x(1)-x(n)+t)/6.d0
      cmat(1,1)=(x(2)-x(n)+t)/3.d0
      cmat(1,2)=(x(2)-x(1))/6.d0
      do jj=2,n-1
        d2f(jj)=(f(jj+1)-f(jj))/(x(jj+1)-x(jj)) &
&              -(f(jj)-f(jj-1))/(x(jj)-x(jj-1))
        cmat(jj,jj-1)=(x(jj)-x(jj-1))/6.d0
        cmat(jj,jj)=(x(jj+1)-x(jj-1))/3.d0
        cmat(jj,jj+1)=(x(jj+1)-x(jj))/6.d0
      enddo
      d2f(n)=(f(1)-f(n))/(x(1)-x(n)+t) &
&           -(f(n)-f(n-1))/(x(n)-x(n-1))
      cmat(n,n-1)=(x(n)-x(n-1))/6.d0
      cmat(n,n)=(x(1)-x(n-1)+t)/3.d0
      cmat(n,1)=(x(1)-x(n)+t)/6.d0

      call loupd(cmat,n,n,iperm,nperm)

      call baksublu(cmat,d2f,n,n,iperm)

      return
      end

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

      subroutine dspline(f,x,d2f,n,df)
!     constructs table of first derivatives of spline function
!     through values f on grid n with second derivatives d2f
      implicit none
      integer n
      double precision f(n),x(n),d2f(n),df(n)
      integer ii,jj

      do ii=1,n-1
        df(ii)=(f(ii+1)-f(ii))/(x(ii+1)-x(ii)) &
&             -(x(ii+1)-x(ii))*d2f(ii)/3.d0 &
&             -(x(ii+1)-x(ii))*d2f(ii+1)/6.d0
      enddo
      df(n)=(f(n)-f(n-1))/(x(n)-x(n-1)) &
&          +(x(n)-x(n-1))*d2f(n-1)/6.d0 &
&          +(x(n)-x(n-1))*d2f(n)/3.d0

      return
      end

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

      subroutine dsplv(f,x,t,d2f,n,xv,dfv)
!     first derivative of spline function
!     through values f on grid n with second derivatives d2f
      implicit none
      integer n
      double precision f(n),x(n),t,d2f(n),xv,dfv
      integer ii,jj
      integer ihi,ilo
      double precision aa,bb,dx

      if (xv.lt.x(1)) then
        ihi=1
        ilo=n
        dx=x(ihi)-x(ilo)+t
      else
        ihi=n
        ilo=1
 100    if (ihi-ilo.gt.1) then
          ii=(ihi+ilo)/2
          if (x(ii).gt.xv) then
            ihi=ii
          else
            ilo=ii
          endif
          goto 100
        endif
        dx=x(ihi)-x(ilo)
      endif
      aa=(x(ihi)-xv)/dx
      bb=1-aa
      dfv=(f(ihi)-f(ilo))/dx &
&        -dx*d2f(ilo)*(3*aa**2-1.d0)/6.d0 &
&        +dx*d2f(ihi)*(3*bb**2-1.d0)/6.d0

      return
      end

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

      subroutine evalspline(f,x,t,d2f,n,xv,fv)
!     evaluate spline through periodic function f on points x
!     with second derivatives d2f at value xv and period t, returning fv
      implicit none
      integer n
      double precision f(n),x(n),d2f(n),t
      double precision xv,fv
      integer ihi,ilo,ii
      double precision aa,bb,dx,f1,f2

      if (xv.lt.x(1)) then
        ihi=1
        ilo=n
        dx=x(ihi)-x(ilo)+t
      else
        ihi=n
        ilo=1
 100    if (ihi-ilo.gt.1) then
          ii=(ihi+ilo)/2
          if (x(ii).gt.xv) then
            ihi=ii
          else
            ilo=ii
          endif
          goto 100
        endif
        dx=x(ihi)-x(ilo)
      endif
      aa=(x(ihi)-xv)/dx
      bb=1-aa
      fv=aa*f(ilo)+bb*f(ihi) &
&        +((aa**3-aa)*d2f(ilo)+(bb**3-bb)*d2f(ihi))*dx**2/6.d0

      return
      end


      REAL             FUNCTION SASINH(X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2001-05-25 SASINH  Krogh Minor change for making .f90 version.
C>> 1996-04-01 SASINH Krogh  Converted to Fortran 77 from SFTRAN.
C>> 1995-10-24 SASINH Krogh  Removed blanks in numbers for C conversion.
C>> 1994-10-19 SASINH Krogh  Changes to use M77CON
C>> 1994-04-19 SASINH CLL Edited type stmts to make DP & SP similar.
C>> 1992-03-13 SASINH FTK  Removed implicit statements.
C>> 1986-03-18 SASINH Lawson  Initial code.
C--S replaces "?": ?ACOSH,?ACSCH,?ACTNH,?ASECH,?ASINH,?ATANH
C--&               ?HYPC, ?HYPS, ?HYPH, ?HYPER, ?ERM1
C
C     This program unit has six entry points for computing
C     the six inverse hyperbolic functions.
C     Using the SFTRAN3 preprocessor.
C     Uses R1MACH(3) to obtain machine precision.
C     All critical constants are given correctly rounded
C     to 25 decimal places. Accuracy of the subprogram
C     adapts to the machine precision up to 25 decimal
C     places precision.
C
C     -----------------------------------------------------------
C
C--   Begin mask code changes
C     The single precision code was tested in May 1983, on a
C     Univac 1100 using the JPL program ST4 that compares a
C     single precision function with a double precision function.
C     Each function was tested on at least 6000 points. Max
C     relative errors are expressed as a multiple of R1MACH(3),
C     which for the Univac 1100 is 2**(-27) = 0.745E-8 .
C
C     FUNCTION            RANGE                MAX REL ERROR
C     --------            -----                -------------
C      SASINH       ALL X                           2.4
C
C      SACOSH       1.0 .LE. X .LE. 1.03            LARGE
C                   1.03 .LE. X .LE. 1.21           3.4
C                   1.21 .LE. X                     2.3
C
C      SATANH       ABS(X) .LE. 0.44                3.2
C                   0.44 .LE. ABS(X) .LE. 0.92      5.1
C                   0.92 .LE. ABS(X) .LE. 1.0       LARGE
C
C      SACSCH       ABS(X) .NE. 0                   3.4
C
C      SASECH       0.0 .LT. X .LE. 0.24            2.0
C                   0.24 .LE. X .LE. 0.68           3.0
C                   0.68 .LE. X .LE. 0.88           10.0
C                   0.88 .LE. X .LE. 1.0            LARGE
C
C      SACTNH       1.0 .LE. ABS(X) .LE. 1.16       LARGE
C                   1.16 .LE. ABS(X) .LE. 2.20      7.1
C                   2.20 LE. ABS(X)                 3.7
C
C     -----------------------------------------------------------
C
C     The D.P. and S.P. codes have each been tested using
C     identities such as X - SINH( ASINH(X) ) = 0. The
C     D.P. codes have about the same accuracy relative to
C     D1MACH(3) as do the S.P. codes relative to R1MACH(3).
C
C--   End mask code changes
C     Error Messages
C     1) Arg .LT. 1                        ( IN SACOSH )
C     2) Arg .LT. or .EQ. to 1             ( IN SATANH )
C     3) ABS(Arg) .LT. or .EQ. to 1        ( IN SACTNH )
C     4) Arg .EQ. 0                        ( IN SACSCH )
C     5) Arg .LT. or .EQ. 0 or Arg .GT. 1  ( IN SASECH )
C
C     -----------------------------------------------------------
C
C     C.L.Lawson and Stella Chan,JPL,Feb 23,1983.
C
      REAL             X
      EXTERNAL SHYPS
      REAL             SHYPS
C
C     Begin computation for SASINH(x)
C     Defined for all x.The value u ranges from negative infinity to
C     positive infinity as x ranges from negative infinity to positive i

C
      IF (X .EQ. 0.E0) THEN
        SASINH=0.E0
      ELSE
        SASINH = SIGN(SHYPS(ABS(X)), X)
      END IF
      RETURN
      END
C
C
      REAL             FUNCTION SACOSH(X)
C
C     Defined (float -valued) for all X greater than or equal to 1.
C     We compute the nonnegative value U ranging from zero to infinity
C     as X ranges from 1 to infinity.The second value would be -U.
      REAL             X
      EXTERNAL SHYPC
      REAL             SHYPC
C
      IF (X .LT. 1.E0) THEN
        SACOSH=0.E0
        CALL SERM1('SACOSH',1,0,'ARG.LT.1','ARG',X,'.')
      ELSE
        SACOSH = SHYPC(X)
      END IF
      RETURN
      END
C
C
      REAL             FUNCTION SATANH(X)
C
C     Defined for -1 < x < +1. The value U ranges from negative
C     infinity to positive infinity.
      REAL             X
      EXTERNAL SHYPH
      REAL             SHYPH
C
      IF (ABS(X) .GE. 1.E0) THEN
        SATANH=0.E0
        CALL SERM1('SATANH',2,0,'ABS(ARG).GE.1','ARG',X,'.')
      ELSE IF (X .EQ. 0.E0) THEN
        SATANH=0.E0
      ELSE
        SATANH = SIGN(SHYPH(ABS(X)), X)
      END IF
      RETURN
      END
C
C
      REAL             FUNCTION SACTNH(X)
C
C     Defined for ABS(X) > 1. The value U ranges from zero to negative
C     infinity as X ranges from negative infinity to -1,and from
C     positive infinity to zero as X ranges from 1 to positive
C     infinity.
      REAL             X
      EXTERNAL SHYPH
      REAL             SHYPH
C
      IF (ABS(X) .LE. 1.E0) THEN
        SACTNH=0.E0
        CALL SERM1('SACTNH',3,0,'ABS(ARG).LE.1','ARG',X,'.')
      ELSE
        SACTNH = SIGN(SHYPH(1.E0 / ABS(X)), X)
      END IF
      RETURN
      END
C
C
      REAL             FUNCTION SACSCH(X)
C
C     Defined for all X not equal to 0. The value varies from
C     zero to negative infinity as X ranges from negative
C     infinity to zero,jumps from negative infinity to positive
C     infinity at zero, and varies from positive infinity to
C     zero as X ranges from zero to positive infinity.
      REAL             X
      EXTERNAL SHYPS
      REAL             SHYPS
C
      IF (X .EQ. 0.E0) THEN
        SACSCH=0.E0
        CALL SERM1('SACSCH',4,0,'ARG.EQ.0','ARG',X,'.')
      ELSE
        SACSCH = SIGN(SHYPS(1.E0 / ABS(X)), X)
      END IF
      RETURN
      END
C
C
      REAL             FUNCTION SASECH(X)
C
C     Defined  (float  valued) for X greater than zero and X less than
C     or equal to 1.E0. We compute the nonnegative value that varies
C     from infinity to zero as X varies from zero to 1.E0. The other
C     value would be the negative of this.
      REAL             X
      EXTERNAL SHYPC
      REAL             SHYPC
C
      IF (X .LE. 0.E0 .OR. X .GT. 1.E0) THEN
        SASECH=0.E0
        CALL SERM1('SASECH',5,0,'ARG.GT.1 OR ARG.LE.0','ARG',X,'.')
      ELSE
        SASECH = SHYPC(1.E0 / X)
      END IF
      RETURN
      END
C
C
      REAL             FUNCTION SHYPS(P)
C
C     Here P > 0.
C     We break the p range into three intervals separated by CUT2
C     and HICUT. In the middle range between CUT2 and HICUT we use
C           SHYPS=LOG(P+SQRT(1+P**2))
C     CUT2 is set to 1.176 to keep the argument of LOG() greater
C     than e = 2.718 to avoid amplification of relative error by LOG().
C       We set HICUT = 10.**16 assuming that all machines on which
C     this code is to run have overflow limit greater than 10.**32
C     and precision not greater than 32 decimal places. Thus we
C     assume that HICUT**2 would not overflow and HICUT**2 plus or
C     minus 1.E0 would evaluate to HICUT**2.
C     The idea of using SHYPS = LOG(P) + LOG(2) for P .GT. HICUT is
C     copied from an ASINH subroutine due to WAYNE FULLERTON.
C
      REAL             P
      EXTERNAL SHYPER
      REAL             CU, CUT2, SHYPER, HICUT, LOGE2
      DATA CUT2, HICUT / 1.176E0, 1.E16 /
      DATA LOGE2 / 0.6931471805599453094172321E0 /
C
      IF (P .GT. HICUT) THEN
        SHYPS = LOG(P) + LOGE2
      ELSE
        CU=SQRT(1.E0+P**2)
        IF (P .LT. CUT2) THEN
          SHYPS = SHYPER(P, CU)
        ELSE
          SHYPS = LOG(P + CU)
        END IF
      END IF
      RETURN
      END
C
C
      REAL             FUNCTION SHYPC(P)
C
C     Here P .GE. 1.
C     See comments in function SHYPS
C     The mid-range formula for SACOSH is:
C         U=LOG(P+SQRT(P**2-1))
C
      REAL             P
      EXTERNAL SHYPER
      REAL             CUT2, SHYPER, HICUT, LOGE2, SU
      DATA CUT2, HICUT / 1.176E0, 1.E16 /
      DATA LOGE2 / 0.6931471805599453094172321E0 /
C
      IF (P .GT. HICUT) THEN
        SHYPC = LOG(P) + LOGE2
      ELSE
        SU = SQRT( (P-1.E0)*(P+1.E0) )
        IF (SU .LT. CUT2) THEN
          SHYPC = SHYPER(SU, P)
        ELSE
          SHYPC = LOG(SU + P)
        END IF
      END IF
      RETURN
      END
C
C
      REAL             FUNCTION SHYPH(Q)
C
C     Here Q satisfies 0 < Q < 1.
C     When Q exceeds CUT1 = 0.463 then (1+Q)/(1-Q) > e = 2.718,
C     and this is large enough to be used as an argument
C     to LOG() without amplification of relative error.
C     When Q is less than CUT1 we transform Q to COSH(U)
C     and SINH(U) and use procedure (LOW RANGE).
C
C     The simple formulas for CU and SU would be
C           CU = 1.E0 / SQRT(1.E0 - Q**2)
C     and   SU = Q / SQRT(1.E0 - Q**2)
C     The more complicated formulas used here have less
C     accumulation of round-of error since
C     0.0 .LT. TERM .LT. 0.1283
C
      REAL             Q
      EXTERNAL SHYPER
      REAL             CUT1, SHYPER, DIF, QSQ, TERM
      DATA CUT1 / 0.463E0 /
C
      IF (Q .LT. CUT1) THEN
        QSQ = Q * Q
        DIF = 1.E0 - QSQ
        TERM = QSQ / (DIF + SQRT(DIF))
        SHYPH = SHYPER(Q + Q*TERM, 1.E0 + TERM)
      ELSE
        SHYPH = 0.5E0 * LOG((1.E0+Q)/(1.E0-Q))
      END IF
      RETURN
      END
C
C  do (LOW RANGE) ==> DYPER(SU, CU)
C
      REAL             FUNCTION SHYPER(SU, CU)
C
C     This procedure controls computation of U, given
C     SU=SINH(U) and CU=COSH(U).These will satisfy
C          0 .LE. SU .LE. 1.176
C     AND  0 .LE. CU .LE. 1.5437
C     so the result, U , will satisfy
C          0 .LE. U .LE. 1.00052
C
C
C     Here the argument R satisfies 0 .LE. R .LE. SINH(0.125) = 0.125326
C
C     ------------------------------------------------------------------
C
C     On the first call to this procedure the value NMAX
C     will be set and saved.
C     FOR MACHINE PRECISION BETWEEN  4.43062 AND  6.45985 USE NMAX =  2
C     FOR MACHINE PRECISION BETWEEN  6.45985 AND  8.43090 USE NMAX =  3
C     FOR MACHINE PRECISION BETWEEN  8.43090 AND 10.36773 USE NMAX =  4
C     FOR MACHINE PRECISION BETWEEN 10.36773 AND 12.28199 USE NMAX =  5
C     FOR MACHINE PRECISION BETWEEN 12.28199 AND 14.18024 USE NMAX =  6
C     FOR MACHINE PRECISION BETWEEN 14.18024 AND 16.06654 USE NMAX =  7
C     FOR MACHINE PRECISION BETWEEN 16.06654 AND 17.94359 USE NMAX =  8
C     FOR MACHINE PRECISION BETWEEN 17.94359 AND 19.81325 USE NMAX =  9
C     FOR MACHINE PRECISION BETWEEN 19.81325 AND 21.67688 USE NMAX = 10
C     FOR MACHINE PRECISION BETWEEN 21.67688 AND 23.53550 USE NMAX = 11
C     FOR MACHINE PRECISION BETWEEN 23.53550 AND 25.38987 USE NMAX = 12
C
      REAL             SU, CU
      EXTERNAL R1MACH
      REAL             B1,B2,C(0:13),CV(8),R1MACH,R,RSQ,SV(8),U,V(8)
      INTEGER I, II, NMAX
      LOGICAL FIRST
      SAVE FIRST, NMAX
C
C     Coeffs for SASINH series. C(0) is half of its true value.
C     This series will be used only for arguments, R , in the
C     range 0 .LE. R .LE. SINH(0.125) = 0.125326 .
C
      DATA   C( 0)/0.5E0/
      DATA   C( 1) /-.1666666666666666666666667E+00/
      DATA   C( 2) /+.7500000000000000000000000E-01/
      DATA   C( 3) /-.4464285714285714285714286E-01/
      DATA   C( 4) /+.3038194444444444444444444E-01/
      DATA   C( 5) /-.2237215909090909090909091E-01/
      DATA   C( 6) /+.1735276442307692307692308E-01/
      DATA   C( 7) /-.1396484375000000000000000E-01/
      DATA   C( 8) /+.1155180089613970588235294E-01/
      DATA   C( 9) /-.9761609529194078947368421E-02/
      DATA   C(10) /+.8390335809616815476190476E-02/
      DATA   C(11) /-.7312525873598845108695652E-02/
      DATA   C(12) /+.6447210311889648437500000E-02/
      DATA   C(13) /-.5740037670841923466435185E-02/
C
C     SV(I) = SINH(V(I))
C     CV(I) = COSH(V(I))
C
      DATA   V( 1) /+.1250000000000000000000000E+00/
      DATA  SV( 1) /+.1253257752411154569820575E+00/
      DATA  CV( 1) /+.1007822677825710859846950E+01/
      DATA   V( 2) /+.2500000000000000000000000E+00/
      DATA  SV( 2) /+.2526123168081683079141252E+00/
      DATA  CV( 2) /+.1031413099879573176159295E+01/
      DATA   V( 3) /+.3750000000000000000000000E+00/
      DATA  SV( 3) /+.3838510679136145687542957E+00/
      DATA  CV( 3) /+.1071140346704586767299498E+01/
      DATA   V( 4) /+.5000000000000000000000000E+00/
      DATA  SV( 4) /+.5210953054937473616224256E+00/
      DATA  CV( 4) /+.1127625965206380785226225E+01/
      DATA   V( 5) /+.6250000000000000000000000E+00/
      DATA  SV( 5) /+.6664922644566160822726066E+00/
      DATA  CV( 5) /+.1201753692975606324229229E+01/
      DATA   V( 6) /+.7500000000000000000000000E+00/
      DATA  SV( 6) /+.8223167319358299807036616E+00/
      DATA  CV( 6) /+.1294683284676844687841708E+01/
      DATA   V( 7) /+.8750000000000000000000000E+00/
      DATA  SV( 7) /+.9910066371442947560531743E+00/
      DATA  CV( 7) /+.1407868656822803158638471E+01/
      DATA   V( 8) /+.1000000000000000000000000E+01/
      DATA  SV( 8) /+.1175201193643801456882382E+01/
      DATA  CV( 8) /+.1543080634815243778477906E+01/
      DATA B1,B2 / 0.52344E0, 4.4306E0 /
c
      data FIRST / .true. /
c
      IF (FIRST) THEN
        FIRST = .FALSE.
C     The following linear expression approximate the NMAX
C     selection criteria described above. The expression
C     never sets NMAX too small but will set NMAX too
C     large, by one, in boundary cases.
        NMAX = 2 + INT(B1 * (-log10(R1MACH(3)) - B2))
        NMAX = MAX(2,MIN(NMAX,12))
      END IF
c
      IF (SU .LE. SV(1)) THEN
        R = SU
      ELSE
        II = MIN ( 7,INT(SU/SV(1)) )
        IF (SU .LT. SV(II)) II = II - 1
C
C     Here we transform to an argument, R , in the range
C     0 .LE. R .LE. SINH(0.125). The simple formula would
C     be :     R = SU * CV(II) - SV(II) * CU
C     However we transform this to extract the factor
C     (SU - SV(II)) for better control of round-off error.
C
        R = (SU-SV(II))*(CV(II)-(SV(II)+SU)*SV(II)/(CV(II)+CU))
      END IF
C
      RSQ = R*R
      U = C(NMAX)
      DO 110 I = NMAX-1, 0, -1
        U = RSQ * U  + C(I)
  110 CONTINUE
      SHYPER = R * (U + 0.5E0)
      IF (SU .GT. SV(1)) SHYPER = V(II) + SHYPER
      return
      end


!*****************************************************************************************
!>
!  Units test for 1d-6d tensor product b-spline interpolation.

    program bspline_test

    use bspline_module
    use bspline_kinds_module, only: wp

    implicit none

    integer,parameter :: nx = 6     !! number of points in x
    integer,parameter :: ny = 6     !! number of points in y
    integer,parameter :: nz = 6     !! number of points in z
    integer,parameter :: nq = 6     !! number of points in q
    integer,parameter :: nr = 6     !! number of points in r
    integer,parameter :: ns = 6     !! number of points in s

    integer,parameter :: kx = 4     !! order in x
    integer,parameter :: ky = 4     !! order in y
    integer,parameter :: kz = 4     !! order in z
    integer,parameter :: kq = 4     !! order in q
    integer,parameter :: kr = 4     !! order in r
    integer,parameter :: ks = 4     !! order in s

    integer,parameter :: iknot = 0  !! automatically select the knots

    real(wp) :: x(nx),y(ny),z(nz),q(nq),r(nr),s(ns)
    real(wp) :: tx(nx+kx),ty(ny+ky),tz(nz+kz),tq(nq+kq),tr(nr+kr),ts(ns+ks)
    real(wp) :: fcn_1d(nx)
    real(wp) :: fcn_2d(nx,ny)
    real(wp) :: fcn_3d(nx,ny,nz)
    real(wp) :: fcn_4d(nx,ny,nz,nq)
    real(wp) :: fcn_5d(nx,ny,nz,nq,nr)
    real(wp) :: fcn_6d(nx,ny,nz,nq,nr,ns)

    real(wp) :: tol
    real(wp),dimension(6) :: val,tru,err,errmax
    logical :: fail
    integer :: i,j,k,l,m,n,idx,idy,idz,idq,idr,ids
    integer,dimension(6) :: iflag
    integer :: inbvx,inbvy,inbvz,inbvq,inbvr,inbvs
    integer :: iloy,iloz,iloq,ilor,ilos

    fail = .false.
    tol = 1.0e-14_wp
    idx = 0
    idy = 0
    idz = 0
    idq = 0
    idr = 0
    ids = 0

     do i=1,nx
        x(i) = dble(i-1)/dble(nx-1)
     end do
     do j=1,ny
        y(j) = dble(j-1)/dble(ny-1)
     end do
     do k=1,nz
        z(k) = dble(k-1)/dble(nz-1)
     end do
     do l=1,nq
        q(l) = dble(l-1)/dble(nq-1)
     end do
     do m=1,nr
        r(m) = dble(m-1)/dble(nr-1)
     end do
     do n=1,ns
        s(n) = dble(n-1)/dble(ns-1)
     end do
     do i=1,nx
                        fcn_1d(i) = f1(x(i))
        do j=1,ny
                        fcn_2d(i,j) = f2(x(i),y(j))
           do k=1,nz
                        fcn_3d(i,j,k) = f3(x(i),y(j),z(k))
              do l=1,nq
                        fcn_4d(i,j,k,l) = f4(x(i),y(j),z(k),q(l))
                 do m=1,nr
                        fcn_5d(i,j,k,l,m) = f5(x(i),y(j),z(k),q(l),r(m))
                     do n=1,ns
                        fcn_6d(i,j,k,l,m,n) = f6(x(i),y(j),z(k),q(l),r(m),s(n))
                     end do
                 end do
              end do
           end do
        end do
     end do

    !have to set these before the first evaluate call:
    inbvx = 1
    inbvy = 1
    inbvz = 1
    inbvq = 1
    inbvr = 1
    inbvs = 1
    iloy  = 1
    iloz  = 1
    iloq  = 1
    ilor  = 1
    ilos  = 1

    ! initialize
    call db1ink(x,nx,fcn_1d,kx,iknot,tx,fcn_1d,iflag(1))
    call db2ink(x,nx,y,ny,fcn_2d,kx,ky,iknot,tx,ty,fcn_2d,iflag(2))
    call db3ink(x,nx,y,ny,z,nz,fcn_3d,kx,ky,kz,iknot,tx,ty,tz,fcn_3d,iflag(3))
    call db4ink(x,nx,y,ny,z,nz,q,nq,fcn_4d,kx,ky,kz,kq,iknot,tx,ty,tz,tq,fcn_4d,iflag(4))
    call db5ink(x,nx,y,ny,z,nz,q,nq,r,nr,fcn_5d,kx,ky,kz,kq,kr,iknot,tx,ty,tz,tq,tr,fcn_5d,iflag(5))
    call db6ink(x,nx,y,ny,z,nz,q,nq,r,nr,s,ns,fcn_6d,kx,ky,kz,kq,kr,ks,iknot,tx,ty,tz,tq,tr,ts,fcn_6d,iflag(6))

    if (any(iflag/=0)) then
        do i=1,6
            if (iflag(i)/=0) then
                write(*,*) 'Error initializing ',i,'D spline: '//get_status_message(iflag(i))
            end if
        end do
    end if

    ! compute max error at interpolation points

     errmax = 0.0_wp
     do i=1,nx
                        call db1val(x(i),idx,&
                                            tx,nx,kx,fcn_1d,val(1),iflag(1),inbvx)
                        tru(1)    = f1(x(i))
                        err(1)    = abs(tru(1)-val(1))
                        errmax(1) = max(err(1),errmax(1))
        do j=1,ny
                        call db2val(x(i),y(j),idx,idy,&
                                            tx,ty,nx,ny,kx,ky,fcn_2d,val(2),iflag(2),&
                                            inbvx,inbvy,iloy)
                        tru(2)    = f2(x(i),y(j))
                        err(2)    = abs(tru(2)-val(2))
                        errmax(2) = max(err(2),errmax(2))
           do k=1,nz
                        call db3val(x(i),y(j),z(k),idx,idy,idz,&
                                            tx,ty,tz,nx,ny,nz,kx,ky,kz,fcn_3d,val(3),iflag(3),&
                                            inbvx,inbvy,inbvz,iloy,iloz)
                        tru(3)    = f3(x(i),y(j),z(k))
                        err(3)    = abs(tru(3)-val(3))
                        errmax(3) = max(err(3),errmax(3))
              do l=1,nq
                        call db4val(x(i),y(j),z(k),q(l),idx,idy,idz,idq,&
                                            tx,ty,tz,tq,nx,ny,nz,nq,kx,ky,kz,kq,fcn_4d,val(4),iflag(4),&
                                            inbvx,inbvy,inbvz,inbvq,iloy,iloz,iloq)
                        tru(4)    = f4(x(i),y(j),z(k),q(l))
                        err(4)    = abs(tru(4)-val(4))
                        errmax(4) = max(err(4),errmax(4))
                do m=1,nr
                        call db5val(x(i),y(j),z(k),q(l),r(m),idx,idy,idz,idq,idr,&
                                            tx,ty,tz,tq,tr,nx,ny,nz,nq,nr,kx,ky,kz,kq,kr,fcn_5d,val(5),iflag(5),&
                                            inbvx,inbvy,inbvz,inbvq,inbvr,iloy,iloz,iloq,ilor)
                        tru(5)    = f5(x(i),y(j),z(k),q(l),r(m))
                        err(5)    = abs(tru(5)-val(5))
                        errmax(5) = max(err(5),errmax(5))
                    do n=1,ns
                        call db6val(x(i),y(j),z(k),q(l),r(m),s(n),idx,idy,idz,idq,idr,ids,&
                                            tx,ty,tz,tq,tr,ts,nx,ny,nz,nq,nr,ns,kx,ky,kz,kq,kr,ks,fcn_6d,val(6),iflag(6),&
                                            inbvx,inbvy,inbvz,inbvq,inbvr,inbvs,iloy,iloz,iloq,ilor,ilos)
                        tru(6)    = f6(x(i),y(j),z(k),q(l),r(m),s(n))
                        err(6)    = abs(tru(6)-val(6))
                        errmax(6) = max(err(6),errmax(6))
                    end do
                end do
              end do
           end do
        end do
     end do

    ! check max error against tolerance
    do i=1,6
        write(*,*) i,'D: max error:', errmax(i)
        if (errmax(i) >= tol) then
            write(*,*)  ' ** test failed ** '
        else
            write(*,*)  ' ** test passed ** '
        end if
        write(*,*) ''
    end do

    contains

        real(wp) function f1(x) !! 1d test function
        implicit none
        real(wp) :: x
        f1 = 0.5_wp * (x*exp(-x) + sin(x) )
        end function f1

        real(wp) function f2(x,y) !! 2d test function
        implicit none
        real(wp) x,y,piov2
        piov2 = 2.0_wp * atan(1.0_wp)
        f2 = 0.5_wp * (y*exp(-x) + sin(piov2*y) )
        end function f2

        real(wp) function f3 (x,y,z) !! 3d test function
        implicit none
        real(wp) x,y,z,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f3 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) )
        end function f3

        real(wp) function f4 (x,y,z,q) !! 4d test function
        implicit none
        real(wp) x,y,z,q,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f4 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q )
        end function f4

        real(wp) function f5 (x,y,z,q,r) !! 5d test function
        implicit none
        real(wp) x,y,z,q,r,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f5 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r )
        end function f5

        real(wp) function f6 (x,y,z,q,r,s) !! 6d test function
        implicit none
        real(wp) x,y,z,q,r,s,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f6 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r + 2.0_wp*s )
        end function f6

    end program bspline_test


      SUBROUTINE flmoon(n,nph,jd,frac)
      INTEGER jd,n,nph
      REAL frac,RAD
      PARAMETER (RAD=3.14159265/180.)
      INTEGER i
      REAL am,as,c,t,t2,xtra
      c=n+nph/4.
      t=c/1236.85
      t2=t**2
      as=359.2242+29.105356*c
      am=306.0253+385.816918*c+0.010730*t2
      jd=2415020+28*n+7*nph
      xtra=0.75933+1.53058868*c+(1.178e-4-1.55e-7*t)*t2
      if(nph.eq.0.or.nph.eq.2)then
        xtra=xtra+(0.1734-3.93e-4*t)*sin(RAD*as)-0.4068*sin(RAD*am)
      else if(nph.eq.1.or.nph.eq.3)then
        xtra=xtra+(0.1721-4.e-4*t)*sin(RAD*as)-0.6280*sin(RAD*am)
      else
        pause 'nph is unknown in flmoon'
      endif
      if(xtra.ge.0.)then
        i=int(xtra)
      else
        i=int(xtra-1.)
      endif
      jd=jd+i
      frac=xtra-i
      return
      END

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


C NMR_PSD: Determine an NMR pore-size distribution from $T_{1}$ data
C --------
C
C NMR relaxation data are used to determine a PSD using the method of
C Munn and Smith [J. Colloid and Interface Sci., 119, 117, 1987].
C
C The problem is the solution of the 1st-order Frredholm equation:
C
C   m(t) (M0 - M(t))/2M0 = \int_{Tmin}^{Tmax} exp(-t/T) f(T) dT
C
C where 1/T = 1/T1(bulk) + gamma/( r*T1(surface) ) and f(T) is therefore
C directly related to the pore-size distribution for r.  The relationship
C is in fact parameterized by:
C
C   1/T = alpha + beta/r
C
C The method of solution is to discretize the above integral to yield:
C
C   m(i) = K(i,j) f(j)
C
C   j = 1, NJ
C   i = 1, NI
C
C where m(i) = m(ti); K(i,j) = exp(-ti/Tj) dT; f(j) = f(Tj).  The step
C dT is such that dT = (Tmax-Tmin) / (NJ - 1) and Tj = Tmin + (j-1)*dT.
C
C The additional criterion on f(j) is that f(j) >= 0 for all j, therefore
C the solution to the above matrix equation is formed in terms of minimizing
C the sum, S:
C
C   S = sum( i=1,NI ) sum( j=1,NJ ) [ m(i) - K(i,j)f(j) ]**2
C
C This is done using the NAG routine E04FDF.
C
C
C The user must supply the following:
C  Number of data points and data values at the time steps
C    NI, m(i), t(i)
C  The range in T and number of steps
C    Tmin, Tmax, NJ (NJ < NI)
C  The parameters of the T <==> T1 transformation
C    alpha, beta
C
C-

C define experimental data
       integer     max_NI
       parameter  (max_NI = 100)
       integer     NI, i
       real*4      x(max_NI), y(max_NI), xx, yy
       real*8      m(max_NI), t(max_NI)
C .. initial guess of mean T1 and m normalization
       real*8      guess_T1, M0
C define steps
       integer     max_NJ
       parameter  (max_NJ = 20)
       integer     NJ, j
       real*8      f(max_NJ), TT(max_NJ), Tmin, Tmax, dT,
     *             g(max_NJ), rr(max_NJ)
C define matrix
       real*8      K(max_NI,max_NJ)
C details of the transformation
       real*8      alpha, beta
C arrays used in the minimization
       integer     max_work, max_iwork
       parameter  (max_work = 7*max_NJ + 2*max_NJ*max_NJ +
     *                        2*max_NJ*max_NI + 3*max_NI )
       parameter  (max_iwork = 500)
       real*8      fsumsq, work( max_work )
       integer     iwork( max_iwork )

C file name character string
       character   file*256, dir*256
C file unit number
       integer     iunit, id
C error status
       integer     status, ifail
C local R*4 variables
       real*4      rm0, rt1, rtmin, rtmax, ralpha, rbeta

C local arrays passed in common
       common /local_data/ m, t, K, TT

C standard include files
       include 'mrao_lib:chrlib_functions.h'
       include 'spec_lib:spec_global.h'
       include 'spec_lib:spec_pars.h'

C initialise
       call cmd_extpars( 'SPECTRUM', dir, status )
       call cmd_getiline( 'nmr_PSD',
     *      dir(1:chr_lenb(dir))//anal_definitions, status)

C find input file name and allocate file
       call cmd_items( 'file', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id, status)
C read data
       call spec_get_data( id, 1, x, NI, status)
       call spec_get_data( id, 2, y, NI, status)
C deallocate
       call spec_deallocate( id, status )

C read in the control data
       call cmd_itemi( 'nj', 1, nj, status )
       call cmd_itemr( 'tmin', 1, rtmin, status )
       Tmin = rtmin
       call cmd_itemr( 'tmax', 1, rtmax, status )
       Tmax = rtmax
       call cmd_itemr( 'm0', 1, rm0, status )
       M0 = rm0
       call cmd_itemr( 'alpha', 1, ralpha, status )
       alpha = ralpha
       call cmd_itemr( 'beta', 1, rbeta, status )
       beta = rbeta
       call cmd_itemr( 't1', 1, rt1, status )
       guess_T1 = rt1

C modify input data to normalize
       do i=1,NI
         t(i) = x(i)
         m(i) = (M0 - y(i)) / (2.0*M0)
       end do

C setup the TT array
       dT = (Tmax - Tmin) / float( NJ-1 )
       do j=1,NJ
         TT(j) = Tmin + float(j-1)*dT
       end do

C setup the matrix
       do i=1,NI
         do j=1,NJ
           K(i,j) = exp( -t(i)/TT(j) ) * dT
         end do
       end do

C setup initial guess for f array
       do j=1,NJ
         f(j) = 0.0
       end do
       j = nint( (guess_T1-Tmin)/dT + 1.0 )
       f(j) = 1.0

C do the minimization
       ifail = 1
       call e04fdf( NI, NJ, f, fsumsq,
     *              iwork, max_iwork, work, max_work, ifail )

C report results
       call io_enqout( iunit )
       write( iunit, 10 ) ifail, fsumsq
10     format( ' On exit IFAIL  = ',I2 /
     *         ' Sum-of-squares = ',1PD12.3 )

C write output
       call cmd_items( 'psd', file, status)
       call io_opefil( iunit, file(1:chr_lenb(file)),
     *                 'WRITE', 0, status )
       write(iunit,*) '\ncols 4'
       write(iunit,*) '\ndata ',NJ
       do j=1,NJ
         rr(j) = beta/( (1.0/TT(j)) - alpha )
         g(j) = f(j)* (beta*TT(j)*TT(J)) / (rr(j)*rr(j))
         write(iunit,*) rr(j), g(j), TT(j), f(j)
       end do
       close (iunit)

C write fit
       call cmd_items( 'fit', file, status)
       call io_opefil( iunit, file(1:chr_lenb(file)),
     *                 'WRITE', 0, status )
       print *,'.. opening fit file: ',iunit,' ',file(1:chr_lenb(file))
       write(iunit,*) '\ncols 2'
       write(iunit,*) '\ndata ',5*NI
       do i=1,5*NI
         xx = t(1) + float(i-1)*(t(NI)-t(1))/float(5*NI-1)
         yy = 0.0
         do j=1,NJ
           yy = yy + f(j) * exp(-xx/TT(j)) * dT
         end do
         yy = M0*(1.0-2.0*yy)
         write(iunit,*) xx, yy
       end do
       close (iunit)

       end
C
C
       subroutine LSFUN1( NI, NJ, f, df )
C      ----------------------------------
C
C Supplied routine to calculate residuals
       integer     NI, NJ
       real*8      f(NJ), df(NI)

       integer     max_NI
       parameter  (max_NI = 100)
       integer     i
       real*8      m(max_NI), t(max_NI)
C define steps
       integer     max_NJ
       parameter  (max_NJ = 20)
       integer     j
       real*8      TT(max_NJ)
C define matrix
       real*8      K(max_NI,max_NJ)
C local arrays passed in common
       common /local_data/ m, t, K, TT

C local variables
       real*8      tot

       do j=1,NJ
         if (f(j).lt.0.0D+0) f(j) = 0.0D+0
       end do

       do i=1,NI

         tot = 0.0D+0
         do j=1,NJ
           tot = tot + K(i,j)*f(j)
         end do
         df(i) = (m(i) - tot)

       end do
       end


      SUBROUTINE AB09KD( JOB, DICO, WEIGHT, EQUIL, ORDSEL, N, NV, NW, M,
     $                   P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
     $                   AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
     $                   NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a reduced order model (Ar,Br,Cr,Dr) for an original
C     state-space representation (A,B,C,D) by using the frequency
C     weighted optimal Hankel-norm approximation method.
C     The Hankel norm of the weighted error
C
C           V*(G-Gr)*W    or    conj(V)*(G-Gr)*conj(W)
C
C     is minimized, where G and Gr are the transfer-function matrices
C     of the original and reduced systems, respectively, and V and W
C     are the transfer-function matrices of the left and right frequency
C     weights, specified by their state space realizations (AV,BV,CV,DV)
C     and (AW,BW,CW,DW), respectively. When minimizing the weighted
C     error V*(G-Gr)*W, V and W must be antistable transfer-function
C     matrices. When minimizing conj(V)*(G-Gr)*conj(W), V and W must be
C     stable transfer-function matrices.
C     Additionally, V and W must be invertible transfer-function
C     matrices, with the feedthrough matrices DV and DW invertible.
C     If the original system is unstable, then the frequency weighted
C     Hankel-norm approximation is computed only for the
C     ALPHA-stable part of the system.
C
C     For a transfer-function matrix G, conj(G) denotes the conjugate
C     of G given by G'(-s) for a continuous-time system or G'(1/z)
C     for a discrete-time system.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the frequency-weighting problem as follows:
C             = 'N':  solve min||V*(G-Gr)*W||_H;
C             = 'C':  solve min||conj(V)*(G-Gr)*conj(W)||_H.
C
C     DICO    CHARACTER*1
C             Specifies the type of the original system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     WEIGHT  CHARACTER*1
C             Specifies the type of frequency weighting, as follows:
C             = 'N':  no weightings are used (V = I, W = I);
C             = 'L':  only left weighting V is used (W = I);
C             = 'R':  only right weighting W is used (V = I);
C             = 'B':  both left and right weightings V and W are used.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily
C             equilibrate the triplet (A,B,C) as follows:
C             = 'S':  perform equilibration (scaling);
C             = 'N':  do not perform equilibration.
C
C     ORDSEL  CHARACTER*1
C             Specifies the order selection method as follows:
C             = 'F':  the resulting order NR is fixed;
C             = 'A':  the resulting order NR is automatically determined
C                     on basis of the given tolerance TOL1.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation,
C             i.e., the order of the matrix A.  N >= 0.
C
C     NV      (input) INTEGER
C             The order of the realization of the left frequency
C             weighting V, i.e., the order of the matrix AV.  NV >= 0.
C
C     NW      (input) INTEGER
C             The order of the realization of the right frequency
C             weighting W, i.e., the order of the matrix AW.  NW >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     NR      (input/output) INTEGER
C             On entry with ORDSEL = 'F', NR is the desired order of
C             the resulting reduced order system.  0 <= NR <= N.
C             On exit, if INFO = 0, NR is the order of the resulting
C             reduced order model. For a system with NU ALPHA-unstable
C             eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N),
C             NR is set as follows: if ORDSEL = 'F', NR is equal to
C             NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the
C             multiplicity of the Hankel singular value HSV(NR-NU+1),
C             NR is the desired order on entry, and NMIN is the order
C             of a minimal realization of the ALPHA-stable part of the
C             given system; NMIN is determined as the number of Hankel
C             singular values greater than NS*EPS*HNORM(As,Bs,Cs), where
C             EPS is the machine precision (see LAPACK Library Routine
C             DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the
C             ALPHA-stable part of the weighted system (computed in
C             HSV(1));
C             if ORDSEL = 'A', NR is the sum of NU and the number of
C             Hankel singular values greater than
C             MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)).
C
C     ALPHA   (input) DOUBLE PRECISION
C             Specifies the ALPHA-stability boundary for the eigenvalues
C             of the state dynamics matrix A. For a continuous-time
C             system (DICO = 'C'), ALPHA <= 0 is the boundary value for
C             the real parts of eigenvalues, while for a discrete-time
C             system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
C             boundary value for the moduli of eigenvalues.
C             The ALPHA-stability domain does not include the boundary.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, if INFO = 0, the leading NR-by-NR part of this
C             array contains the state dynamics matrix Ar of the
C             reduced order system in a real Schur form.
C             The resulting A has a block-diagonal form with two blocks.
C             For a system with NU ALPHA-unstable eigenvalues and
C             NS ALPHA-stable eigenvalues (NU+NS = N), the leading
C             NU-by-NU block contains the unreduced part of A
C             corresponding to ALPHA-unstable eigenvalues.
C             The trailing (NR+NS-N)-by-(NR+NS-N) block contains
C             the reduced part of A corresponding to ALPHA-stable
C             eigenvalues.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the original input/state matrix B.
C             On exit, if INFO = 0, the leading NR-by-M part of this
C             array contains the input/state matrix Br of the reduced
C             order system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original state/output matrix C.
C             On exit, if INFO = 0, the leading P-by-NR part of this
C             array contains the state/output matrix Cr of the reduced
C             order system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the original input/output matrix D.
C             On exit, if INFO = 0, the leading P-by-M part of this
C             array contains the input/output matrix Dr of the reduced
C             order system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     AV      (input/output) DOUBLE PRECISION array, dimension (LDAV,NV)
C             On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV
C             part of this array must contain the state matrix AV of a
C             state space realization of the left frequency weighting V.
C             On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
C             NV-by-NV part of this array contains a real Schur form
C             of the state matrix of a state space realization of the
C             inverse of V.
C             AV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDAV    INTEGER
C             The leading dimension of the array AV.
C             LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
C             LDAV >= 1,         if WEIGHT = 'R' or 'N'.
C
C     BV      (input/output) DOUBLE PRECISION array, dimension (LDBV,P)
C             On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part
C             of this array must contain the input matrix BV of a state
C             space realization of the left frequency weighting V.
C             On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
C             NV-by-P part of this array contains the input matrix of a
C             state space realization of the inverse of V.
C             BV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDBV    INTEGER
C             The leading dimension of the array BV.
C             LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
C             LDBV >= 1,         if WEIGHT = 'R' or 'N'.
C
C     CV      (input/output) DOUBLE PRECISION array, dimension (LDCV,NV)
C             On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part
C             of this array must contain the output matrix CV of a state
C             space realization of the left frequency weighting V.
C             On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
C             P-by-NV part of this array contains the output matrix of a
C             state space realization of the inverse of V.
C             CV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDCV    INTEGER
C             The leading dimension of the array CV.
C             LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B';
C             LDCV >= 1,        if WEIGHT = 'R' or 'N'.
C
C     DV      (input/output) DOUBLE PRECISION array, dimension (LDDV,P)
C             On entry, if WEIGHT = 'L' or 'B', the leading P-by-P part
C             of this array must contain the feedthrough matrix DV of a
C             state space realization of the left frequency weighting V.
C             On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
C             P-by-P part of this array contains the feedthrough matrix
C             of a state space realization of the inverse of V.
C             DV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDDV    INTEGER
C             The leading dimension of the array DV.
C             LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B';
C             LDDV >= 1,        if WEIGHT = 'R' or 'N'.
C
C     AW      (input/output) DOUBLE PRECISION array, dimension (LDAW,NW)
C             On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW
C             part of this array must contain the state matrix AW of
C             a state space realization of the right frequency
C             weighting W.
C             On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
C             NW-by-NW part of this array contains a real Schur form of
C             the state matrix of a state space realization of the
C             inverse of W.
C             AW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDAW    INTEGER
C             The leading dimension of the array AW.
C             LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
C             LDAW >= 1,         if WEIGHT = 'L' or 'N'.
C
C     BW      (input/output) DOUBLE PRECISION array, dimension (LDBW,M)
C             On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part
C             of this array must contain the input matrix BW of a state
C             space realization of the right frequency weighting W.
C             On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
C             NW-by-M part of this array contains the input matrix of a
C             state space realization of the inverse of W.
C             BW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDBW    INTEGER
C             The leading dimension of the array BW.
C             LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
C             LDBW >= 1,         if WEIGHT = 'L' or 'N'.
C
C     CW      (input/output) DOUBLE PRECISION array, dimension (LDCW,NW)
C             On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part
C             of this array must contain the output matrix CW of a state
C             space realization of the right frequency weighting W.
C             On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
C             M-by-NW part of this array contains the output matrix of a
C             state space realization of the inverse of W.
C             CW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDCW    INTEGER
C             The leading dimension of the array CW.
C             LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B';
C             LDCW >= 1,        if WEIGHT = 'L' or 'N'.
C
C     DW      (input/output) DOUBLE PRECISION array, dimension (LDDW,M)
C             On entry, if WEIGHT = 'R' or 'B', the leading M-by-M part
C             of this array must contain the feedthrough matrix DW of
C             a state space realization of the right frequency
C             weighting W.
C             On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
C             M-by-M part of this array contains the feedthrough matrix
C             of a state space realization of the inverse of W.
C             DW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDDW    INTEGER
C             The leading dimension of the array DW.
C             LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B';
C             LDDW >= 1,        if WEIGHT = 'L' or 'N'.
C
C     NS      (output) INTEGER
C             The dimension of the ALPHA-stable subsystem.
C
C     HSV     (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, the leading NS elements of this array contain
C             the Hankel singular values, ordered decreasingly, of the
C             ALPHA-stable part of the weighted original system.
C             HSV(1) is the Hankel norm of the ALPHA-stable weighted
C             subsystem.
C
C     Tolerances
C
C     TOL1    DOUBLE PRECISION
C             If ORDSEL = 'A', TOL1 contains the tolerance for
C             determining the order of reduced system.
C             For model reduction, the recommended value is
C             TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the
C             interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the
C             Hankel-norm of the ALPHA-stable part of the weighted
C             original system (computed in HSV(1)).
C             If TOL1 <= 0 on entry, the used default value is
C             TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of
C             ALPHA-stable eigenvalues of A and EPS is the machine
C             precision (see LAPACK Library Routine DLAMCH).
C             If ORDSEL = 'F', the value of TOL1 is ignored.
C
C     TOL2    DOUBLE PRECISION
C             The tolerance for determining the order of a minimal
C             realization of the ALPHA-stable part of the given system.
C             The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs).
C             This value is used by default if TOL2 <= 0 on entry.
C             If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK = MAX(1,M,c),      if DICO = 'C',
C             LIWORK = MAX(1,N,M,c),    if DICO = 'D',
C             where  c = 0,             if WEIGHT = 'N',
C                    c = 2*P,           if WEIGHT = 'L',
C                    c = 2*M,           if WEIGHT = 'R',
C                    c = MAX(2*M,2*P),  if WEIGHT = 'B'.
C             On exit, if INFO = 0, IWORK(1) contains NMIN, the order of
C             the computed minimal realization.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where
C             LDW1 = 0 if WEIGHT = 'R' or 'N' and
C             LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) )
C                    if WEIGHT = 'L' or WEIGHT = 'B',
C             LDW2 = 0 if WEIGHT = 'L' or 'N' and
C             LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) )
C                    if WEIGHT = 'R' or WEIGHT = 'B', with
C                a = 0,    b = 0,     if DICO = 'C' or  JOB = 'N',
C                a = 2*NV, b = 2*NW,  if DICO = 'D' and JOB = 'C';
C             LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2,
C             LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) +
C                    MAX( 3*M+1, MIN(N,M)+P ).
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  with ORDSEL = 'F', the selected order NR is greater
C                   than NSMIN, the sum of the order of the
C                   ALPHA-unstable part and the order of a minimal
C                   realization of the ALPHA-stable part of the given
C                   system; in this case, the resulting NR is set equal
C                   to NSMIN;
C             = 2:  with ORDSEL = 'F', the selected order NR is less
C                   than the order of the ALPHA-unstable part of the
C                   given system; in this case NR is set equal to the
C                   order of the ALPHA-unstable part.
C
C     Error Indicator
C
C     INFO    INTEGER
C             =  0:  successful exit;
C             <  0:  if INFO = -i, the i-th argument had an illegal
C                    value;
C             =  1:  the computation of the ordered real Schur form of A
C                    failed;
C             =  2:  the separation of the ALPHA-stable/unstable
C                    diagonal blocks failed because of very close
C                    eigenvalues;
C             =  3:  the reduction of AV or AV-BV*inv(DV)*CV to a
C                    real Schur form failed;
C             =  4:  the reduction of AW or AW-BW*inv(DW)*CW to a
C                    real Schur form failed;
C             =  5:  JOB = 'N' and AV is not antistable, or
C                    JOB = 'C' and AV is not stable;
C             =  6:  JOB = 'N' and AW is not antistable, or
C                    JOB = 'C' and AW is not stable;
C             =  7:  the computation of Hankel singular values failed;
C             =  8:  the computation of stable projection in the
C                    Hankel-norm approximation algorithm failed;
C             =  9:  the order of computed stable projection in the
C                    Hankel-norm approximation algorithm differs
C                    from the order of Hankel-norm approximation;
C             = 10:  DV is singular;
C             = 11:  DW is singular;
C             = 12:  the solution of the Sylvester equation failed
C                    because the zeros of V (if JOB = 'N') or of conj(V)
C                    (if JOB = 'C') are not distinct from the poles
C                    of G1sr (see METHOD);
C             = 13:  the solution of the Sylvester equation failed
C                    because the zeros of W (if JOB = 'N') or of conj(W)
C                    (if JOB = 'C') are not distinct from the poles
C                    of G1sr (see METHOD).
C
C     METHOD
C
C     Let G be the transfer-function matrix of the original
C     linear system
C
C          d[x(t)] = Ax(t) + Bu(t)
C          y(t)    = Cx(t) + Du(t),                          (1)
C
C     where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
C     for a discrete-time system. The subroutine AB09KD determines
C     the matrices of a reduced order system
C
C          d[z(t)] = Ar*z(t) + Br*u(t)
C          yr(t)   = Cr*z(t) + Dr*u(t),                      (2)
C
C     such that the corresponding transfer-function matrix Gr minimizes
C     the Hankel-norm of the frequency-weighted error
C
C             V*(G-Gr)*W,                                    (3)
C     or
C             conj(V)*(G-Gr)*conj(W).                        (4)
C
C     For minimizing (3), V and W are assumed to be antistable, while
C     for minimizing (4), V and W are assumed to be stable transfer-
C     function matrices.
C
C     Note: conj(G) = G'(-s) for a continuous-time system and
C           conj(G) = G'(1/z) for a discrete-time system.
C
C     The following procedure is used to reduce G (see [1]):
C
C     1) Decompose additively G as
C
C          G = G1 + G2,
C
C        such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and
C        G2 = (A2,B2,C2,0) has only ALPHA-unstable poles.
C
C     2) Compute G1s, the stable projection of V*G1*W or
C        conj(V)*G1*conj(W), using explicit formulas [4].
C
C     3) Determine G1sr, the optimal Hankel-norm approximation of G1s
C        of order r.
C
C     4) Compute G1r, the stable projection of either inv(V)*G1sr*inv(W)
C        or conj(inv(V))*G1sr*conj(inv(W)), using explicit formulas [4].
C
C     5) Assemble the reduced model Gr as
C
C           Gr = G1r + G2.
C
C     To reduce the weighted ALPHA-stable part G1s at step 3, the
C     optimal Hankel-norm approximation method of [2], based on the
C     square-root balancing projection formulas of [3], is employed.
C
C     The optimal weighted approximation error satisfies
C
C          HNORM[V*(G-Gr)*W] = S(r+1),
C     or
C          HNORM[conj(V)*(G-Gr)*conj(W)] = S(r+1),
C
C     where S(r+1) is the (r+1)-th Hankel singular value of G1s, the
C     transfer-function matrix computed at step 2 of the above
C     procedure, and HNORM(.) denotes the Hankel-norm.
C
C     REFERENCES
C
C     [1] Latham, G.A. and Anderson, B.D.O.
C         Frequency-weighted optimal Hankel-norm approximation of stable
C         transfer functions.
C         Systems & Control Letters, Vol. 5, pp. 229-236, 1985.
C
C     [2] Glover, K.
C         All optimal Hankel norm approximation of linear
C         multivariable systems and their L-infinity error bounds.
C         Int. J. Control, Vol. 36, pp. 1145-1193, 1984.
C
C     [3] Tombs M.S. and Postlethwaite I.
C         Truncated balanced realization of stable, non-minimal
C         state-space systems.
C         Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
C
C     [4] Varga A.
C         Explicit formulas for an efficient implementation
C         of the frequency-weighting model reduction approach.
C         Proc. 1993 European Control Conference, Groningen, NL,
C         pp. 693-696, 1993.
C
C     NUMERICAL ASPECTS
C
C     The implemented methods rely on an accuracy enhancing square-root
C     technique.
C                                         3
C     The algorithms require less than 30N  floating point operations.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000.
C     D. Sima, University of Bucharest, May 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, May 2000.
C     Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1,
C     by A. Varga, 1992.
C
C     REVISIONS
C
C     A. Varga, Australian National University, Canberra, November 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000.
C              Oct. 2001, March 2005.
C
C     KEYWORDS
C
C     Frequency weighting, model reduction, multivariable system,
C     state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  C100, ONE, ZERO
      PARAMETER         ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, EQUIL, JOB, ORDSEL, WEIGHT
      INTEGER           INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW,
     $                  LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N,
     $                  NR, NS, NV, NW, P
      DOUBLE PRECISION  ALPHA, TOL1, TOL2
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), AV(LDAV,*), AW(LDAW,*),
     $                  B(LDB,*), BV(LDBV,*), BW(LDBW,*),
     $                  C(LDC,*), CV(LDCV,*), CW(LDCW,*),
     $                  D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*),
     $                  HSV(*)
C     .. Local Scalars ..
      LOGICAL           CONJS, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW
      INTEGER           IA, IB, IERR, IWARNL, KI, KL, KU, KW, LW, NMIN,
     $                  NRA, NU, NU1
      DOUBLE PRECISION  ALPWRK, MAXRED, RCOND, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          AB07ND, AB09CX, AB09KX, TB01ID, TB01KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      INFO   = 0
      IWARN  = 0
      CONJS  = LSAME( JOB,    'C' )
      DISCR  = LSAME( DICO,   'D' )
      FIXORD = LSAME( ORDSEL, 'F' )
      LEFTW  = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' )
      RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' )
      FRWGHT = LEFTW .OR. RIGHTW
C
      IF ( DISCR .AND. CONJS ) THEN
         IA = 2*NV
         IB = 2*NW
      ELSE
         IA = 0
         IB = 0
      END IF
      LW = 1
      IF( LEFTW )
     $   LW = MAX( LW, NV*(NV+5), NV*N + MAX( IA, P*N, P*M ) )
      IF( RIGHTW )
     $   LW = MAX( LW, MAX( NW*(NW+5), NW*N + MAX( IB, M*N, P*M ) ) )
      LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 )
      LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) +
     $                             MAX ( 3*M + 1, MIN( N, M ) + P ) )
C
C     Check the input scalar arguments.
C
      IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR.
     $                 LSAME( EQUIL, 'N' ) ) ) THEN
         INFO = -4
      ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( NV.LT.0 ) THEN
         INFO = -7
      ELSE IF( NW.LT.0 ) THEN
         INFO = -8
      ELSE IF( M.LT.0 ) THEN
         INFO = -9
      ELSE IF( P.LT.0 ) THEN
         INFO = -10
      ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN
         INFO = -11
      ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR.
     $    ( .NOT.DISCR .AND.   ALPHA.GT.ZERO ) ) THEN
         INFO = -12
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -18
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -20
      ELSE IF( LDAV.LT.1 .OR. ( LEFTW  .AND. LDAV.LT.NV ) ) THEN
         INFO = -22
      ELSE IF( LDBV.LT.1 .OR. ( LEFTW  .AND. LDBV.LT.NV ) ) THEN
         INFO = -24
      ELSE IF( LDCV.LT.1 .OR. ( LEFTW  .AND. LDCV.LT.P  ) ) THEN
         INFO = -26
      ELSE IF( LDDV.LT.1 .OR. ( LEFTW  .AND. LDDV.LT.P  ) ) THEN
         INFO = -28
      ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN
         INFO = -30
      ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN
         INFO = -32
      ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M  ) ) THEN
         INFO = -34
      ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M  ) ) THEN
         INFO = -36
      ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN
         INFO = -40
      ELSE IF( LDWORK.LT.LW ) THEN
         INFO = -43
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB09KD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 ) THEN
         NR = 0
         NS = 0
         IWORK(1) = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( LSAME( EQUIL, 'S' ) ) THEN
C
C        Scale simultaneously the matrices A, B and C:
C        A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a
C        diagonal matrix.
C        Workspace: N.
C
         MAXRED = C100
         CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                DWORK, INFO )
      END IF
C
C     Correct the value of ALPHA to ensure stability.
C
      ALPWRK = ALPHA
      IF( DISCR ) THEN
         IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) )
      ELSE
         IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) )
      END IF
C
C     Allocate working storage.
C
      KU = 1
      KL = KU + N*N
      KI = KL + N
      KW = KI + N
C
C     Reduce A to a block-diagonal real Schur form, with the
C     ALPHA-unstable part in the leading diagonal position, using a
C     non-orthogonal similarity transformation, A <- inv(T)*A*T, and
C     apply the transformation to B and C: B <- inv(T)*B and C <- C*T.
C
C     Workspace needed:      N*(N+2);
C     Additional workspace:  need   3*N;
C                            prefer larger.
C
      CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA,
     $             B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL),
     $             DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR )
C
      IF( IERR.NE.0 ) THEN
         IF( IERR.NE.3 ) THEN
            INFO = 1
         ELSE
            INFO = 2
         END IF
         RETURN
      END IF
C
      WRKOPT = DWORK(KW) + DBLE( KW-1 )
C
C     Compute the stable projection of the weighted ALPHA-stable part.
C
C     Workspace: need   MAX( 1, LDW1, LDW2 ),
C                LDW1 = 0 if WEIGHT = 'R' or 'N' and
C                LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) )
C                       if WEIGHT = 'L' or 'B',
C                LDW2 = 0 if WEIGHT = 'L' or 'N' and
C                LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) )
C                       if WEIGHT = 'R' or 'B',
C                where  a = 0,    b = 0,    if DICO = 'C' or  JOB = 'N',
C                       a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C';
C                prefer larger.
C
      NS = N - NU
C
C     Finish if only unstable part is present.
C
      IF( NS.EQ.0 ) THEN
         NR = NU
         IWORK(1) = 0
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
      NU1 = NU + 1
      IF( FRWGHT ) THEN
         CALL AB09KX( JOB, DICO, WEIGHT, NS, NV, NW, M, P, A(NU1,NU1),
     $                LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD,
     $                AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
     $                AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
     $                DWORK, LDWORK, IWARNL, IERR )
C
         IF( IERR.NE.0 ) THEN
C
C           Note: Only IERR = 1 or IERR = 2 are possible.
C           Set INFO to 3 or 4.
C
            INFO = IERR + 2
            RETURN
         END IF
C
         IF( IWARNL.NE.0 ) THEN
C
C           Stability/antistability of V and W are compulsory.
C
            IF( IWARNL.EQ.1 .OR. IWARNL.EQ.3 ) THEN
               INFO = 5
            ELSE
               INFO = 6
            END IF
            RETURN
         END IF
C
         DWORK(1) = MAX( WRKOPT, DWORK(1) )
      END IF
C
C     Determine a reduced order approximation of the ALPHA-stable part.
C
C     Workspace: need   MAX( LDW3, LDW4 ),
C                LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2,
C                LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) +
C                       MAX( 3*M+1, MIN(N,M)+P );
C                prefer larger.
C
      IWARNL = 0
      IF( FIXORD ) THEN
         NRA = MAX( 0, NR - NU )
         IF( NRA.EQ.0 )
     $      IWARNL = 2
      ELSE
         NRA = 0
      END IF
      CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA,
     $             B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1,
     $             TOL2, IWORK, DWORK, LDWORK, IWARN, IERR )
C
      IWARN = MAX( IWARN, IWARNL )
      IF( IERR.NE.0 ) THEN
C
C        Set INFO = 7, 8 or 9.
C
         INFO = IERR + 5
         RETURN
      END IF
C
      WRKOPT = MAX( WRKOPT, DWORK(1) )
      NMIN = IWORK(1)
C
C     Compute the state space realizations of the inverses of V and W.
C
C     Integer workspace: need   c,
C     Real workspace:    need   MAX(1,2*c),
C                        where  c = 0,             if WEIGHT = 'N',
C                               c = 2*P,           if WEIGHT = 'L',
C                               c = 2*M,           if WEIGHT = 'R',
C                               c = MAX(2*M,2*P),  if WEIGHT = 'B'.
C
      IF( LEFTW ) THEN
         CALL AB07ND( NV, P, AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
     $                RCOND, IWORK, DWORK, LDWORK, IERR )
         IF( IERR.NE.0 ) THEN
            INFO = 10
            RETURN
         END IF
      END IF
      IF( RIGHTW ) THEN
         CALL AB07ND( NW, M, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
     $                RCOND, IWORK, DWORK, LDWORK, IERR )
         IF( IERR.NE.0 ) THEN
            INFO = 11
            RETURN
         END IF
      END IF
C
      WRKOPT = MAX( WRKOPT, DWORK(1) )
C
C     Compute the stable projection of weighted reduced ALPHA-stable
C     part.
C
      IF( FRWGHT ) THEN
         CALL AB09KX( JOB, DICO, WEIGHT, NRA, NV, NW, M, P, A(NU1,NU1),
     $                LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD,
     $                AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
     $                AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
     $                DWORK, LDWORK, IWARNL, IERR )
C
         IF( IERR.NE.0 ) THEN
            IF( IERR.LE.2 ) THEN
C
C              Set INFO to 3 or 4.
C
               INFO = IERR + 2
            ELSE
C
C              Set INFO to 12 or 13.
C
               INFO = IERR + 9
            END IF
            RETURN
         END IF
      END IF
C
      NR = NRA + NU
      IWORK(1) = NMIN
      DWORK(1) = MAX( WRKOPT, DWORK(1) )
C
      RETURN
C *** Last line of AB09KD ***
      END


      subroutine DEVVUN(A, LDA, N, EVALR, EVALI, VEC, IFLAG, WORK)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c     This file contains DEVVUN and CDIV.
c>> 1996-03-30 DEVUNN Krogh  MIN0 => MIN, added external statement.
c>> 1994-11-02 DEVVUN Krogh  Changes to use M77CON
c>> 1992-04-23 DEVVUN CLL   Declaring all variables.
c>> 1992-04-22 DEVVUN Krogh Removed unused labels 330 and 1220.
c>> 1992-03-05 DEVVUN Krogh Initial version, converted from EISPACK.
c
c     This subroutine uses slight modifcations of EISPACK routines
c     BALANC, ELMHES, ELTRAN, HQR2 and BALBAK to get the eigenvalues and
c     eigenvectors of a general real matrix by the QR method.  The first
c     two are are encapsulated in DEVBH.  The following three are given
c     inline here.
c
c     ELTRAN is a translation of the algol procedure ELMTRANS,
c     Num. Math. 16, 181-204(1970) by Peters and Wilkinson.
c     Handbook for Auto. Comp., Vol.ii-Linear Algebra, 372-395(1971).
c
c     HQR2 is a translation of the ALGOL procedure HQR2,
c     Num. Math. 16, 181-204(1970) by Peters and Wilkinson.
c     Handbook for Auto. Comp., Vol.ii-Linear Algebra, 372-395(1971).
c
c     BALBAK is a translation of the ALGOL procedure BALBAK,
c     Num. Math. 13, 293-304(1969) by Parlett and Reinsch.
c     Handbook for Auto. Comp., Vol.ii-Linear Algebra, 315-326(1971).
c
c     This subroutine finds the eigenvalues and eigenvectors
c     of a real general matrix by the QR method.
c
c     On input
c
c     LDA  must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c     N    is the order of the matrix.
c     A    contains the input matrix whose eigenvalues and eigenvectors
c          are desired.
c
c     On output
c     A    has been destroyed.
c     EVALR and EVALI contain real and imaginary parts, respectively, of
c          the eigenvalues.  The eigenvalues are given in order of
c          increasing real parts.  When real parts are equal they are
c          given in order of increasing absolute complex part.  Complex
c          conjugate pairs of values appear consecutively with
c          the eigenvalue having the positive imaginary part first.  If
c          an error exit is made, the eigenvalues should be correct
c          (but unordered) for indices IFLAG(1)+1,...,N.
c     VEC  contains the real and imaginary parts of the eigenvectors.
c          if the I-th eigenvalue is real, the I-th column of VEC
c          contains its eigenvector.  If the I-th eigenvalue is complex
c          with positive imaginary part, the I-th and (I+1)-th
c          columns of VEC contain the real and imaginary parts of its
c          eigenvector.  The eigenvectors are unnormalized.  If an
c          error exit is made, none of the eigenvectors has been found.
c     IFLAG(1) is set to
c          1   If all eigenvalues are real.
c          2   If some eigenvalues are complex.
c          3   If N < 1 on the initial entry.
c          4   If the limit of 30*N iterations is exhausted.
c     ------------------------------------------------------------------
c--D replaces "?": ?EVVUN, ?EVBH, ?NRM2, ?SCAL, ?CDIV
c     ------------------------------------------------------------------
      external DNRM2
      integer I,J,K,L,M,N,EN,NA,LDA,IGH,ITN,ITS,LOW,MP,MP2,ENM2
      integer II, IFLAG(N), LTYPE
      double precision A(LDA,N),EVALR(N),EVALI(N),VEC(LDA,N), WORK(N)
      double precision P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2
      double precision DNRM2
      logical NOTLAS
c     ------------------------------------------------------------------
c
      call DEVBH(A, LDA, N, LOW, IGH, IFLAG, WORK)
      LTYPE = 1
c
c    -------------------------------- ELTRAN ---------------------------
c
c     Accumulate the stabilized elementary similarity transformations
c     used in the preceding reduction of the matrix to upper Hessenberg
c     form.
c
c     .......... initialize VEC to identity matrix ..........
      do 20 J = 1, N
         do 10 I = 1, N
            VEC(I,J) = 0.0D0
   10    continue
         VEC(J,J) = 1.0D0
   20 continue
      if (IGH .gt. LOW+1) then
         do 50 MP = IGH-1, LOW+1, -1
            do 30 I = MP+1, IGH
               VEC(I,MP) = A(I,MP-1)
   30       continue
            I = IFLAG(MP)
            if (I .ne. MP) then
               do 40 J = MP, IGH
                  VEC(MP,J) = VEC(I,J)
                  VEC(I,J) = 0.0D0
   40          continue
               VEC(I,MP) = 1.0D0
            end if
   50    continue
      end if
c
c    -------------------------------- HQR2 -----------------------------
c
c     Find the eigenvalues of a real upper Hessenberg matrix by the QR
c     method.
c
      IFLAG(1) = 0
      NORM = 0.0D0
      K = 1
c     .......... store roots isolated by balanc
c                and compute matrix norm ..........
      do 70 I = 1, N
         do 60 J = K, N
            NORM = NORM + abs(A(I,J))
   60    continue
         K = I
         if ((I .lt. LOW) .or. (I .gt. IGH)) then
            EVALR(I) = A(I,I)
            EVALI(I) = 0.0D0
         end if
   70 continue
      EN = IGH
      T = 0.0D0
      ITN = 30*N
c     .......... search for next eigenvalues ..........
   80 if (EN .lt. LOW) go to 340
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
c     .......... look for single small sub-diagonal element
   90 do 100 L = EN, LOW+1, -1
         S = abs(A(L-1,L-1)) + abs(A(L,L))
         if (S .eq. 0.0D0) S = NORM
         TST1 = S
         TST2 = TST1 + abs(A(L,L-1))
         if (TST2 .eq. TST1) go to 110
  100 continue
c     .......... form shift ..........
  110 X = A(EN,EN)
      if (L .eq. EN) go to 270
      Y = A(NA,NA)
      W = A(EN,NA) * A(NA,EN)
      if (L .eq. NA) go to 280
      if (ITN .le. 0) then
c     .......... set error -- all eigenvalues have not
c                converged after 30*N iterations ..........
         call ERMSG('DEVVUN', EN, 0,
     1'ERROR NO. is index of eigenvalue causing convergence failure.',
     2            '.')
         IFLAG(1) = 4
         if (EN .le. 0) IFLAG(1) = 3
         return
      end if
      if (ITS .ne. 10 .and. ITS .ne. 20) go to 130
c     .......... form exceptional shift ..........
      T = T + X
      do 120 I = LOW, EN
         A(I,I) = A(I,I) - X
  120 continue
      S = abs(A(EN,NA)) + abs(A(NA,ENM2))
      X = 0.75D0 * S
      Y = X
      W = -0.4375D0 * S * S
  130 ITS = ITS + 1
      ITN = ITN - 1
c     .......... look for two consecutive small sub-diagonal elements.
      do 140 M = ENM2, L, -1
         ZZ = A(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / A(M+1,M) + A(M,M+1)
         Q = A(M+1,M+1) - ZZ - R - S
         R = A(M+2,M+1)
         S = abs(P) + abs(Q) + abs(R)
         P = P / S
         Q = Q / S
         R = R / S
         if (M .eq. L) go to 150
         TST1 = abs(P)*(abs(A(M-1,M-1)) + abs(ZZ) + abs(A(M+1,M+1)))
         TST2 = TST1 + abs(A(M,M-1))*(abs(Q) + abs(R))
         if (TST2 .eq. TST1) go to 150
  140 continue
  150 MP2 = M + 2
      do 160 I = MP2, EN
         A(I,I-2) = 0.0D0
         if (I .ne. MP2) A(I,I-3) = 0.0D0
  160 continue
c     .......... double QR step involving rows L to EN and
c                columns M to EN ..........
      do 260 K = M, NA
         NOTLAS = K .ne. NA
         if (K .ne. M) then
            P = A(K,K-1)
            Q = A(K+1,K-1)
            R = 0.0D0
            if (NOTLAS) R = A(K+2,K-1)
            X = abs(P) + abs(Q) + abs(R)
            if (X .eq. 0.0D0) go to 260
            P = P / X
            Q = Q / X
            R = R / X
         end if
         S = sign(sqrt(P*P+Q*Q+R*R),P)
         if (K .ne. M) then
            A(K,K-1) = -S * X
         else
            if (L .ne. M) A(K,K-1) = -A(K,K-1)
         end if
         P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
         if (NOTLAS) then
c        .......... row modification ..........
            do 200 J = K, N
               P = A(K,J) + Q * A(K+1,J) + R * A(K+2,J)
               A(K,J) = A(K,J) - P * X
               A(K+1,J) = A(K+1,J) - P * Y
               A(K+2,J) = A(K+2,J) - P * ZZ
  200       continue
            J = min(EN,K+3)
c        .......... column modification ..........
            do 210 I = 1, J
               P = X * A(I,K) + Y * A(I,K+1) + ZZ * A(I,K+2)
               A(I,K) = A(I,K) - P
               A(I,K+1) = A(I,K+1) - P * Q
               A(I,K+2) = A(I,K+2) - P * R
  210       continue
c        .......... accumulate transformations ..........
            do 220 I = LOW, IGH
               P = X * VEC(I,K) + Y * VEC(I,K+1) + ZZ * VEC(I,K+2)
               VEC(I,K) = VEC(I,K) - P
               VEC(I,K+1) = VEC(I,K+1) - P * Q
               VEC(I,K+2) = VEC(I,K+2) - P * R
  220       continue
         else
c        .......... row modification ..........
            do 230 J = K, N
               P = A(K,J) + Q * A(K+1,J)
               A(K,J) = A(K,J) - P * X
               A(K+1,J) = A(K+1,J) - P * Y
  230       continue
c
            J = min(EN,K+3)
c        .......... column modification ..........
            do 240 I = 1, J
               P = X * A(I,K) + Y * A(I,K+1)
               A(I,K) = A(I,K) - P
               A(I,K+1) = A(I,K+1) - P * Q
  240       continue
c        .......... accumulate transformations ..........
            do 250 I = LOW, IGH
               P = X * VEC(I,K) + Y * VEC(I,K+1)
               VEC(I,K) = VEC(I,K) - P
               VEC(I,K+1) = VEC(I,K+1) - P * Q
  250       continue
         end if
  260 continue
      go to 90
c     .......... one root found ..........
  270 A(EN,EN) = X + T
      EVALR(EN) = A(EN,EN)
      EVALI(EN) = 0.0D0
      EN = NA
      go to 80
c     .......... two roots found ..........
  280 P = (Y - X) / 2.0D0
      Q = P * P + W
      ZZ = sqrt(abs(Q))
      A(EN,EN) = X + T
      X = A(EN,EN)
      A(NA,NA) = Y + T
      if (Q .ge. 0.0D0) then
c        .......... real pair ..........
         ZZ = P + sign(ZZ,P)
         EVALR(NA) = X + ZZ
         EVALR(EN) = EVALR(NA)
         if (ZZ .ne. 0.0D0) EVALR(EN) = X - W / ZZ
         EVALI(NA) = 0.0D0
         EVALI(EN) = 0.0D0
         X = A(EN,NA)
         S = abs(X) + abs(ZZ)
         P = X / S
         Q = ZZ / S
         R = sqrt(P*P+Q*Q)
         P = P / R
         Q = Q / R
c        .......... row modification ..........
         do 290 J = NA, N
            ZZ = A(NA,J)
            A(NA,J) = Q * ZZ + P * A(EN,J)
            A(EN,J) = Q * A(EN,J) - P * ZZ
  290    continue
c        .......... column modification ..........
         do 300 I = 1, EN
            ZZ = A(I,NA)
            A(I,NA) = Q * ZZ + P * A(I,EN)
            A(I,EN) = Q * A(I,EN) - P * ZZ
  300    continue
c        .......... accumulate transformations ..........
         do 310 I = LOW, IGH
            ZZ = VEC(I,NA)
            VEC(I,NA) = Q * ZZ + P * VEC(I,EN)
            VEC(I,EN) = Q * VEC(I,EN) - P * ZZ
  310    continue
      else
c        .......... complex pair ..........
         LTYPE = 2
         EVALR(NA) = X + P
         EVALR(EN) = X + P
         EVALI(NA) = ZZ
         EVALI(EN) = -ZZ
      end if
      EN = ENM2
      go to 80
c     .......... all roots found.  Backsubstitute to find
c                vectors of upper triangular form ..........
  340 if (NORM .eq. 0.0D0) go to 1000
      do 800 EN = N, 1, -1
         P = EVALR(EN)
         Q = EVALI(EN)
         NA = EN - 1
         if (Q) 710, 600, 800
c     .......... real vector ..........
  600    M = EN
         A(EN,EN) = 1.0D0
         do 700 I = NA, 1, -1
            W = A(I,I) - P
            R = 0.0D0
            do 610 J = M, EN
               R = R + A(I,J) * A(J,EN)
  610       continue
            if (EVALI(I) .lt. 0.0D0) then
               ZZ = W
               S = R
            else
               M = I
               if (EVALI(I) .eq. 0.0D0) then
                  T = W
                  if (T .eq. 0.0D0) then
                     TST1 = NORM
                     T = TST1
  640                T = 0.01D0 * T
                     TST2 = NORM + T
                     if (TST2 .gt. TST1) go to 640
                  end if
                  A(I,EN) = -R / T
               else
c           .......... solve real equations ..........
                  X = A(I,I+1)
                  Y = A(I+1,I)
                  Q = (EVALR(I)-P) * (EVALR(I)-P) + EVALI(I) * EVALI(I)
                  T = (X * S - ZZ * R) / Q
                  A(I,EN) = T
                  if (abs(X) .gt. abs(ZZ)) then
                     A(I+1,EN) = (-R - W * T) / X
                  else
                     A(I+1,EN) = (-S - Y * T) / ZZ
                  end if
               end if
c           .......... overflow control ..........
               T = abs(A(I,EN))
               if (T .ne. 0.0D0) then
                  TST1 = T
                  TST2 = TST1 + 1.0D0/TST1
                  if (TST2 .le. TST1) then
                     do 690 J = I, EN
                        A(J,EN) = A(J,EN)/T
  690                continue
                  end if
               end if
            end if
  700    continue
c     .......... end real vector ..........
         go to 800
c
c     .......... complex vector ..........
  710    M = NA
c     .......... last vector component chosen imaginary so that
c                eigenvector matrix is triangular ..........
         if (abs(A(EN,NA)) .gt. abs(A(NA,EN))) then
            A(NA,NA) = Q / A(EN,NA)
            A(NA,EN) = -(A(EN,EN) - P) / A(EN,NA)
         else
            call DCDIV(0.0D0,-A(NA,EN),A(NA,NA)-P,Q,A(NA,NA),A(NA,EN))
         end if
         A(EN,NA) = 0.0D0
         A(EN,EN) = 1.0D0
         ENM2 = NA - 1
         do 760 I = ENM2, 1, -1
            W = A(I,I) - P
            RA = 0.0D0
            SA = 0.0D0
            do 730 J = M, EN
               RA = RA + A(I,J) * A(J,NA)
               SA = SA + A(I,J) * A(J,EN)
  730       continue
            if (EVALI(I) .lt. 0.0D0) then
               ZZ = W
               R = RA
               S = SA
            else
               M = I
               if (EVALI(I) .eq. 0.0D0) then
                  call DCDIV(-RA,-SA,W,Q,A(I,NA),A(I,EN))
               else
c           .......... solve complex equations ..........
                  X = A(I,I+1)
                  Y = A(I+1,I)
                  VR = (EVALR(I)-P)*(EVALR(I)-P)+EVALI(I)*EVALI(I)-Q*Q
                  VI = (EVALR(I) - P) * 2.0D0 * Q
                  if (VR .eq. 0.0D0 .and. VI .eq. 0.0D0) then
                     TST1 = NORM * (abs(W)+abs(Q)+abs(X)+abs(Y)+abs(ZZ))
                     VR = TST1
  740                VR = 0.01D0 * VR
                     TST2 = TST1 + VR
                     if (TST2 .gt. TST1) go to 740
                  end if
                  call DCDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI,
     x                   A(I,NA),A(I,EN))
                  if (abs(X) .gt. abs(ZZ) + abs(Q)) then
                     A(I+1,NA) = (-RA - W * A(I,NA) + Q * A(I,EN)) / X
                     A(I+1,EN) = (-SA - W * A(I,EN) - Q * A(I,NA)) / X
                  else
                     call DCDIV(-R-Y*A(I,NA),-S-Y*A(I,EN),ZZ,Q,
     x                   A(I+1,NA),A(I+1,EN))
                  end if
               end if
c           .......... overflow control ..........
               T = max(abs(A(I,NA)), abs(A(I,EN)))
               if (T .ne. 0.0D0) then
                  TST1 = T
                  TST2 = TST1 + 1.0D0/TST1
                  if (TST2 .le. TST1) then
                     do 750 J = I, EN
                        A(J,NA) = A(J,NA)/T
                        A(J,EN) = A(J,EN)/T
  750                continue
                  end if
               end if
            end if
  760    continue
c     .......... end complex vector ..........
  800 continue
c     .......... end back substitution.
c                vectors of isolated roots ..........
      do 840 I = 1, N
         if (I .ge. LOW .and. I .le. IGH) go to 840
c
         do 820 J = I, N
            VEC(I,J) = A(I,J)
  820    continue
c
  840 continue
c     .......... multiply by transformation matrix to give
c                vectors of original full matrix.
      do 880 J = N, LOW, -1
         M = min(J,IGH)
c
         do 880 I = LOW, IGH
            ZZ = 0.0D0
c
            do 860 K = LOW, M
               ZZ = ZZ + VEC(I,K) * A(K,J)
  860       continue
c
            VEC(I,J) = ZZ
  880 continue
c
 1000 continue
c
c    ------------------------------ BALBAK -----------------------------
c
c     Form eigenvectors of a real general matrix by back transforming
c     those of the corresponding balanced matrix determined by BALANC.
c
      if (IGH .ne. LOW) then
         do 1110 I = LOW, IGH
            S = WORK(I)
c        .......... left hand eigenvectors are back transformed
c                   if the foregoing statement is replaced by
c                   S=1.0D0/WORK(I). ..........
            do 1100 J = 1, N
               VEC(I,J) = VEC(I,J) * S
 1100       continue
 1110    continue
      end if
c     ......... for I=LOW-1 step -1 until 1,
c               IGH+1 step 1 until N do -- ..........
      do 1140 II = 1, N
         I = II
         if ((I .lt. LOW) .or. (I .gt. IGH)) then
            if (I .lt. LOW) I = LOW - II
            K = WORK(I)
            if (K .ne. I) then
               do 1130 J = 1, N
                  S = VEC(I,J)
                  VEC(I,J) = VEC(K,J)
                  VEC(K,J) = S
 1130          continue
            end if
         end if
 1140 continue
c                        Normalize the eigenvectors
      do 1220 I = 1, N
         P = DNRM2(N, VEC(1, I), 1)
         if (EVALI(I) .eq. 0.D0) then
            call DSCAL(N, sign(1.D0, VEC(1,I)) / P, VEC(1,I), 1)
         else if (EVALI(I) .gt. 0.D0) then
            Q = DNRM2(N, VEC(1, I+1), 1)
            if (P .gt. Q) then
               P = P * sqrt(1.D0 + (Q/P)**2)
            else if (Q .ne. 0.D0) then
               P = Q * sqrt(1.D0 + (P/Q)**2)
            else
               go to 1220
            end if
            if (VEC(1, I+1) .eq. 0.D0) then
               P = sign(1.D0, VEC(1,I+1)) / P
               Q = 0.D0
            else if (abs(VEC(1, I)) .gt. abs(VEC(1, I+1))) then
               P = 1.D0 / (P*sqrt(1.D0+(VEC(1,I+1)/VEC(1,I))**2))
               Q = P * (VEC(1,I+1) / abs(VEC(1,I)))
               P = sign(P, VEC(1, I))
            else
               Q = 1.D0 / (P*sqrt(1.D0+(VEC(1,I)/VEC(1,I+1))**2))
               P = Q * (VEC(1,I) / abs(VEC(1,I+1)))
               Q = sign(Q, VEC(1, I+1))
            end if
            do 1200 J = 1, N
               R = P * VEC(J, I) + Q * VEC(J, I+1)
               VEC(J, I+1) = P * VEC(J, I+1) - Q * VEC(J, I)
               VEC(J, I) = R
 1200       continue
         end if
 1220 continue
c-- Begin mask code changes
c                        Set up for Shell sort
c             Sort so real parts are algebraically increasing
c             For = real parts, so abs(imag. parts) are increasing
c             For both =, sort on index -- preserves complex pair order
c-- End mask code changes
      do 2000 I = 1, N
         IFLAG(I) = I
 2000 continue
      L = 1
      do 2010 K = 1, N
         L = 3*L + 1
         if (L .ge. N) go to 2020
 2010 continue
 2020 L = max(1, (L-4) / 9)
 2030 do 2100 J = L+1, N
         K = IFLAG(J)
         P = EVALR(K)
         I = J - L
 2040    if (P - EVALR(IFLAG(I))) 2070, 2050, 2080
 2050    if (abs(EVALI(K)) - abs(EVALI(IFLAG(I)))) 2070, 2060, 2080
 2060    if (K .gt. IFLAG(I)) go to 2080
 2070    IFLAG(I+L) = IFLAG(I)
         I = I - L
         if (I .gt. 0) go to 2040
 2080    IFLAG(I+L) = K
 2100 continue
      L = (L-1) / 3
      if (L .ne. 0) go to 2030
c              Indices in IFLAG now give the desired order --
c              Move entries to get this order.
 2110 do 2150 I = L+1, N
         if (IFLAG(I) .ne. I) then
            L = I
            M = I
            P = EVALR(I)
            Q = EVALI(I)
            do 2115 J = 1, N
               WORK(J) = VEC(J, I)
 2115       continue
 2120       K = IFLAG(M)
            IFLAG(M) = M
            if (K .ne. L) then
               EVALR(M) = EVALR(K)
               EVALI(M) = EVALI(K)
               do 2130 J = 1, N
                  VEC(J, M) = VEC(J, K)
 2130          continue
               M = K
               go to 2120
            else
               EVALR(M) = P
               EVALI(M) = Q
               do 2140 J = 1, N
                  VEC(J, M) = WORK(J)
 2140          continue
               go to 2110
            end if
         end if
 2150 continue
      IFLAG(1) = LTYPE
      return
      end
c     ==================================================================
      subroutine DCDIV(AR,AI,BR,BI,CR,CI)
c
c     complex division, (CR,CI) = (AR,AI)/(BR,BI)
c     ------------------------------------------------------------------
      double precision AR,AI,BR,BI,CR,CI
      double precision S,ARS,AIS,BRS,BIS
      S = abs(BR) + abs(BI)
      ARS = AR/S
      AIS = AI/S
      BRS = BR/S
      BIS = BI/S
      S = BRS**2 + BIS**2
      CR = (ARS*BRS + AIS*BIS)/S
      CI = (AIS*BRS - ARS*BIS)/S
      return
      end


SUBROUTINE deemat(dee,e,v)
!
! This subroutine returns the elastic dee matrix for ih=3 (plane strain),
! ih=4 (axisymmetry or plane strain elastoplasticity) or ih=6
! (three dimensions).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::e,v
 REAL(iwp),INTENT(OUT)::dee(:,:)
 REAL(iwp)::v1,v2,c,vv,zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp,two=2.0_iwp
 INTEGER::i,ih
 dee=zero
 ih=UBOUND(dee,1)
 v1=one-v
 c=e/((one+v)*(one-two*v))
 SELECT CASE(ih)
 CASE(3)
   dee(1,1)=v1*c
   dee(2,2)=v1*c
   dee(1,2)=v*c
   dee(2,1)=v*c
   dee(3,3)=pt5*c*(one-two*v)
 CASE(4)
   dee(1,1)=v1*c
   dee(2,2)=v1*c
   dee(4,4)=v1*c
   dee(3,3)=pt5*c*(one-two*v)
   dee(1,2)=v*c
   dee(2,1)=v*c
   dee(1,4)=v*c
   dee(4,1)=v*c
   dee(2,4)=v*c
   dee(4,2)=v*c
 CASE(6)
   v2=v/(one-v)
   vv=(one-two*v)/(one-v)*pt5
   DO i=1,3
     dee(i,i)=one
   END DO
   DO i=4,6
     dee(i,i)=vv
   END DO
   dee(1,2)=v2
   dee(2,1)=v2
   dee(1,3)=v2
   dee(3,1)=v2
   dee(2,3)=v2
   dee(3,2)=v2
   dee=dee*e/(two*(one+v)*vv)
 CASE DEFAULT
   WRITE(*,*)'wrong size for dee matrix'
 END SELECT
RETURN
END SUBROUTINE deemat