C$Procedure      PSV2PL ( Point and spanning vectors to plane )

      SUBROUTINE PSV2PL ( POINT, SPAN1, SPAN2, PLANE )

C$ Abstract
C
C     Make a SPICELIB plane from a point and two spanning vectors.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     PLANES
C
C$ Keywords
C
C     GEOMETRY
C     MATH
C     PLANE
C
C$ Declarations

      INTEGER               UBPL
      PARAMETER           ( UBPL   =   4 )

      DOUBLE PRECISION      POINT (    3 )
      DOUBLE PRECISION      SPAN1 (    3 )
      DOUBLE PRECISION      SPAN2 (    3 )
      DOUBLE PRECISION      PLANE ( UBPL )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     POINT,
C     SPAN1,
C     SPAN2      I   A point and two spanning vectors defining a plane.
C     PLANE      O   An array representing the plane.
C
C$ Detailed_Input
C
C     POINT,
C     SPAN1,
C     SPAN2          are, respectively, a point and two spanning vectors
C                    that define a geometric plane in three-dimensional
C                    space. The plane is the set of vectors
C
C                       POINT   +   s * SPAN1   +   t * SPAN2
C
C                    where s and t are real numbers.  The spanning
C                    vectors SPAN1 and SPAN2 must be linearly
C                    independent, but they need not be orthogonal or
C                    unitized.
C
C$ Detailed_Output
C
C     PLANE          is a SPICELIB plane that represents the geometric
C                    plane defined by POINT, SPAN1, and SPAN2.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If SPAN1 and SPAN2 are linearly dependent, then the vectors
C         POINT, SPAN1, and SPAN2 do not define a plane.  The error
C         SPICE(DEGENERATECASE) is signalled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     SPICELIB geometry routines that deal with planes use the `plane'
C     data type to represent input and output planes.  This data type
C     makes the subroutine interfaces simpler and more uniform.
C
C     The SPICELIB routines that produce SPICELIB planes from data that
C     define a plane are:
C
C        NVC2PL ( Normal vector and constant to plane )
C        NVP2PL ( Normal vector and point to plane    )
C        PSV2PL ( Point and spanning vectors to plane )
C
C     The SPICELIB routines that convert SPICELIB planes to data that
C     define a plane are:
C
C        PL2NVC ( Plane to normal vector and constant )
C        PL2NVP ( Plane to normal vector and point    )
C        PL2PSV ( Plane to point and spanning vectors )
C
C     Any of these last three routines may be used to convert this
C     routine's output, PLANE, to another representation of a
C     geometric plane.
C
C$ Examples
C
C     1)  Project a vector V orthogonally onto a plane defined by
C         POINT, SPAN1, and SPAN2.  PROJ is the projection we want; it
C         is the closest vector in the plane to V.
C
C            CALL PSV2PL ( POINT,   SPAN1,   SPAN2,   PLANE )
C            CALL VPRJP  ( V,       PLANE,   PROJ           )
C
C
C     2)  Find the plane determined by a spacecraft's position vector
C         relative to a central body and the spacecraft's velocity
C         vector.  We assume that all vectors are given in the same
C         coordinate system.
C
C            C
C            C     POS is the spacecraft's position, relative to
C            C     the central body.  VEL is the spacecraft's velocity
C            C     vector.  POS is a point (vector, if you like) in
C            C     the orbit plane, and it is also one of the spanning
C            C     vectors of the plane.
C            C
C                  CALL PSV2PL ( POS, POS, VEL, PLANE )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] `Calculus and Analytic Geometry', Thomas and Finney.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 31-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VMINUS call.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 01-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     point and spanning vectors to plane
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 31-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VMINUS call.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDOT

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local parameters
C

C
C     The contents of SPICELIB planes are as follows:
C
C        Elements NMLPOS through NMLPOS + 2 contain a unit normal
C        vector for the plane.
C
C        Element CONPOS contains a constant for the plane;  every point
C        X in the plane satisifies
C
C           < X, PLANE(NMLPOS) >  =  PLANE(CONPOS).
C
C        The plane constant is the distance of the plane from the
C        origin; the normal vector, scaled by the constant, is the
C        closest point in the plane to the origin.
C
C
      INTEGER               NMLPOS
      PARAMETER           ( NMLPOS = 1 )

      INTEGER               CONPOS
      PARAMETER           ( CONPOS = 4 )

C
C     Local variables
C
      DOUBLE PRECISION      TMPVEC ( 3 )

C
C     This routine checks in only if an error is discovered.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

C
C     Find the unitized cross product of SPAN1 and SPAN2; this is our
C     unit normal vector, or possibly its inverse.
C
      CALL UCRSS (  SPAN1,  SPAN2,  PLANE(NMLPOS)  )

      IF (  VZERO ( PLANE(NMLPOS) )  ) THEN
         CALL CHKIN  ( 'PSV2PL'                         )
         CALL SETMSG ( 'Spanning vectors are parallel.' )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'          )
         CALL CHKOUT ( 'PSV2PL'                         )
         RETURN
      END IF

C
C     Find the plane constant corresponding to the unit normal
C     vector we've found.
C
      PLANE(CONPOS)  =  VDOT ( PLANE(NMLPOS), POINT )

C
C     The constant should be the distance of the plane from the
C     origin.  If the constant is negative, negate both it and the
C     normal vector.
C
      IF ( PLANE(CONPOS) .LT. 0.D0 ) THEN

         PLANE(CONPOS) =   -PLANE(CONPOS)
         CALL VMINUS     (  PLANE(NMLPOS), TMPVEC        )
         CALL VEQU       (  TMPVEC,        PLANE(NMLPOS) )

      END IF

      RETURN
      END


      FUNCTION ellf(phi,ak)
      REAL ellf,ak,phi
CU    USES rf
      REAL s,rf
      s=sin(phi)
      ellf=s*rf(cos(phi)**2,(1.-s*ak)*(1.+s*ak),1.)
      return
      END

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


      double precision FUNCTION DRCOMP (A, 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-06-18 DRCOMP Krogh  Removed blanks inside floating pt. nums.
C>> 1998-10-29 DRCOMP Krogh  Moved external statement up for mangle.
C>> 1994-11-08 CLL Edited data stmt for conversion to C.
C>> 1994-10-20 DRCOMP Krogh  Changes to use M77CON
C>> 1992-05-06 DRCOMP WVS JPL Conversion from NSWC to Math 77
c--D replaces "?": ?CSEVL, ?GAMMA, ?GAM1, ?INITS, ?RCOMP
c--   &              ?RLOG, ?XPARG
C ----------------------------------------------------------------------
C                EVALUATION OF EXP(-X)*X**A/GAMMA(A)
c ----------------------------------------------------------------------
C     RT2PIN = 1/SQRT(2*PI)
c -------------------------
      double precision RT2PIN
      parameter (RT2PIN=.398942280401432677939946059934D0)
c -------------------------
      double precision A, X, T, U
      external DCSEVL, DGAMMA, DGAM1, DRLOG, DXPARG, D1MACH
      double precision DCSEVL, DGAMMA, DGAM1, DRLOG, DXPARG, D1MACH
      double precision C(30), EMIN
      integer NTERMS
      save NTERMS, EMIN
      data NTERMS /0/
c     Coefficients for a 30 term truncated Chebyshev series for the
c     tail of the Stirling approximation for log gamma (a), i.e.
c     10/a*sum(bernoulli(2*m)/((2*m)*(2*m-1))*(10/a)^(2*m),m=1..30):
      data C /
     1  +1.6666674603806317936070839523784458533810D-1,
     2  -0.27778224326356936403488508628449409187D-4,
     3  +0.39686751449471417966822710527999178D-7,
     4  -0.148869543950843614683173607368649D-9,
     5  +0.1053394436947088748911134694152D-11,
     6  -0.12017062666093330302702077565D-13,
     7  +0.201455314614512105435465085D-15,
     8  -0.4667111367329679717841157D-17,
     9  +0.143038901715103888195513D-18, -0.5615023733620632617039D-20,
     B  +0.275468595656664717191D-21,    -0.16574673341842014242D-22,
     D  +0.1205878144005562980D-23,      -0.105029344505420423D-24,
     F  +0.10888441731031588D-25,        -0.1345007495569099D-26,
     2  +0.198172466731588D-27,          -0.35717869246269D-28,
     4  +0.7475856209303D-29,            -0.1991899701570D-29,
     6  +0.510170672127D-30,             -0.177502712854D-30,
     8  +0.43613516909D-31,              -0.17176901844D-31,
     A  +0.3387002917D-32,               -0.1399833946D-32,
     C  +0.188634194D-33,                -0.79096000D-34,
     E  +0.5378442D-35,                  -0.2252006D-35 /
c
      DRCOMP = 0.0D0
      IF (X .EQ. 0.0D0) RETURN
      IF (A .LT. 20.0D0) THEN
C
         T = A*LOG(X) - X
         IF (T .LT. DXPARG(1)) RETURN
         IF (A .LT. 1.0D0) THEN
            DRCOMP = (A*EXP(T))*(1.0D0 + DGAM1(A))
            RETURN
         END IF
         DRCOMP = EXP(T)/DGAMMA(A)
      ELSE
         U = X/A
         IF (U .EQ. 0.0D0) RETURN
         if (nterms .eq. 0) then
            call dinits (c,30,0.1d0*d1mach(4),nterms)
            emin = dxparg(1)
         end if
         T = -(dcsevl ((10.0d0/a)**2, c, nterms)/a + a*drlog(u))
         IF (T .GE. emin) DRCOMP = RT2PIN * SQRT(A) * EXP(T)
      END IF
      RETURN
      END


      real*8 sand,silt,clay,bulk,ans1
      real*8 a_saxton,b_saxton,wp_saxton,fc_saxton,sw_saxton
      real*8 bc_wres,bc_wqs,bs_a,bc_l,wp_bc,fc_bc,sw_bc
      real*8 wp_ch,fc_ch,sw_ch,b,lsmp,smp

      sand = 50.0d0
      silt = 30.0d0
      clay = 100.0d0 - sand - silt
      bulk = 1.33d0
      org = 10.0d0

*************************************************************************
*                            Saxton
*************************************************************************
      b_saxton=-3.14-0.00222*clay**2-3.484/10**5*sand**2*clay
      a_saxton=100.0*exp(-4.396-0.0715*clay-4.88/10**4*sand**2-4.28/
     &(10**5)*(sand**2)*clay)
      wp_saxton = (1500.0/a_saxton)**(1/b_saxton)
      fc_saxton = exp((2.302-log(a_saxton))/b_saxton)
      sw_saxton = 0.332 - 0.0007251*sand + 0.1276*log10(clay)

*************************************************************************
*                        Brookes Corey
*************************************************************************
      bc_wres = 0.0d0
      bc_wqs = 1.0-bulk/2.65
      ans1 = -0.475662 +0.005165*sand + 0.002066*silt -
     &  0.023327*clay -0.040628*bulk +
     &  0.006824*org -0.000136162*sand**2 -
     &  0.0000954716*silt**2 +0.000298891*clay**2 -
     &  0.0637*bulk**2 -0.00031679*org**2 +
     &  0.0000010388*sand**3 +0.0000010299*silt**3 -
     &  0.0000013251*clay**3

      bc_l = 10**ans1

      ans1 = 0.4104+0.002684*sand+0.006354*silt+
     &0.17766*bulk+0.00013855*clay**2

      bc_a = 1/10**ans1

      wp_bc = bc_wres + (bc_wqs - bc_wres)*(15300.0*bc_a)**(-bc_l)
      fc_bc = bc_wres + (bc_wqs - bc_wres)*(51.0*bc_a)**(-bc_l)
      sw_bc = 1.0-bulk/2.65

**************************************************************************
*                Cosby Hornberger Clapp Ginn
**************************************************************************
      b = 3.1d0 + (0.157d0*clay) - (0.003d0*sand)
      swc = 50.5d0 - (0.142d0*sand) - (0.037d0*clay)
      lsmp = 1.54d0 - (0.0095d0*sand) + (0.0063d0*silt)
      smp = 10.0d0**lsmp
      fc_ch = ((((306.0d0/smp)**(-1.0d0/b))*swc)/100.0d0)*0.78d0*bulk
      wp_ch = ((((15300.0d0/smp)**(-1.0d0/b))*swc)/100.0d0)*0.78d0*bulk
      sw_ch = (((306.0d0/smp)**(-1.0d0/b))*swc/100.d0)*bulk

      print*,wp_saxton,fc_saxton,sw_saxton
      print*,wp_bc,fc_bc,sw_bc
      print*,wp_ch,fc_ch,sw_ch

      print*,sw_saxton-wp_saxton,fc_saxton-wp_saxton
      print*,sw_bc-wp_bc,fc_bc-wp_bc
      print*,sw_ch-wp_ch,fc_ch-wp_ch

      stop
      end


program distributed_array
    use :: mpi
    implicit none
    integer, parameter :: local_rows = 3, local_cols = 4, &
                          nr_dims = 2
    logical, parameter, dimension(nr_dims) :: periodic = [ .false., .false. ]
    logical, parameter :: reorder = .false.
    integer :: proc_rows, proc_cols, row, col, proc_row, proc_col
    integer :: rank, size, ierr, val
    integer, dimension(nr_dims) :: dims = [ 0, 0 ], cart_coords
    integer, dimension(local_rows, local_cols) :: data
    integer :: cart_comm

    call MPI_Init(ierr)
    call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
    call MPI_Comm_size(MPI_COMM_WORLD, size, ierr)
    call MPI_Dims_create(size, nr_dims, dims, ierr)
    proc_rows = dims(1)
    proc_cols = dims(2)
    call MPI_Cart_create(MPI_COMM_WORLD, nr_dims, dims, periodic, &
                         reorder, cart_comm, ierr)
    call MPI_Cart_coords(cart_comm, rank, nr_dims, cart_coords, ierr)
    proc_row = cart_coords(1)
    proc_col = cart_coords(2)
   do row = 1, local_rows
       do col = 1, local_cols
           val = proc_row*local_rows*local_cols*proc_cols + &
                 (row - 1)*local_cols*proc_cols + &
                 (col - 1) + proc_col*local_cols
           data(row, col) = val
       end do
   end do
   call MPI_Barrier(MPI_COMM_WORLD, ierr)
   call MPI_Finalize(ierr)
end program distributed_array


!
! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
module matmul_m
contains
  subroutine matmul(A, B, C, m, n, k)
    implicit none
    real, intent(in) :: A(m,k)
    real, intent(in) :: B(k,n)
    real, intent(inout) :: C(m,n)
    integer, intent(in) :: m, n, k

    integer :: i, j, l

    do i = 1, m
       do j = 1, n
          do l = 1, k
             C(i,j) = C(i,j) + A(i,l) * B(l,j)
          enddo
       end do
    end do
  end subroutine matmul
end module matmul_m


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc              mndbin : dblint test program                          cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real fac,facx,aint,exint,dblint,xb,xe,yb,ye
      integer i,j,kx,kx1,ky,ky1,mx,my,m0,m1,m2,m3,nc,nkx1,nky1,nx,ny
      real tx(15),ty(15),c(100),x(6),y(6),wrk(50)
c  we set up the end points of the integration domains.
      mx = 6
      my = 6
      do 10 i=1,6
      x(i) = (i-1)*0.2
      y(i) = x(i)
  10  continue
c  loop for different spline degrees with respect to the x-variable
      do 300 kx=1,5,2
c  the knots in the x-direction
        tx(kx+2) = 0.4
        tx(kx+3) = 0.7
        tx(kx+4) = 0.9
        kx1 = kx+1
        nx = 3+2*kx1
        j = nx
        do 20 i=1,kx1
          tx(i) = 0.
          tx(j) = 1.
          j = j-1
  20    continue
c  loop for different spline degrees with respect to the y-variable
      do 200 ky=2,3
c  the knots in the y-direction
        ty(ky+2) = 0.3
        ty(ky+3) = 0.8
        ky1 = ky+1
        ny = 2+2*ky1
        j = ny
        do 30 i=1,ky1
          ty(i) = 0.
          ty(j) = 1.
          j = j-1
  30    continue
c  we generate the b-spline coefficients for the test function x*y
        nkx1 = nx-kx1
        nky1 = ny-ky1
        do 40 i=1,nky1
          c(i) = 0.
  40    continue
        do 50 i=2,nkx1
          c((i-1)*nky1+1) = 0.
  50    continue
        fac = kx*ky
        m0 = 1
        do 70 i=2,nkx1
          m1 = m0+nky1
          facx = (tx(i+kx)-tx(i))/fac
          do 60 j=2,nky1
            m2 = m0+1
            m3 = m1+1
            c(m3) = c(m1)+c(m2)-c(m0)+facx*(ty(j+ky)-ty(j))
            m0 = m0+1
            m1 = m1+1
  60      continue
          m0 = m0+1
  70    continue
c  printing of the spline information
        write(6,900) kx,ky
        write(6,910)
        write(6,920) (tx(i),i=1,nx)
        write(6,930)
        write(6,920) (ty(i),i=1,ny)
        nc = nkx1*nky1
        write(6,940)
        write(6,950) (c(i),i=1,nc)
c  integration of the tensor product spline
        write(6,960)
        j = 6
        do 100 i=1,3
          xb = x(i)
          yb = xb
          xe = x(j)
          ye = xe
          j = j-1
          aint = dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk)
          exint = (xe-xb)*(xe+xb)*(ye-yb)*(ye+yb)*0.25
          write(6,970) xb,xe,yb,ye,aint,exint
 100    continue
 200    continue
 300  continue
      stop
c  format statements.
 900  format(33h0tensor product spline of degrees,2i3)
 910  format(1x,40hposition of the knots in the x-direction)
 920  format(1x,15f5.1)
 930  format(1x,40hposition of the knots in the y-direction)
 940  format(23h b-spline coefficients )
 950  format(1x,8f9.4)
 960  format(1h0,5x,2hxb,5x,2hxe,5x,2hyb,5x,2hye,6x,6hdblint,7x,5hexint)
 970  format(1x,4f7.1,2f12.5)
      end


*> \brief \b SLAIC1 applies one step of incremental condition estimation.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAIC1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
*
*       .. Scalar Arguments ..
*       INTEGER            J, JOB
*       REAL               C, GAMMA, S, SEST, SESTPR
*       ..
*       .. Array Arguments ..
*       REAL               W( J ), X( J )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAIC1 applies one step of incremental condition estimation in
*> its simplest version:
*>
*> Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
*> lower triangular matrix L, such that
*>          twonorm(L*x) = sest
*> Then SLAIC1 computes sestpr, s, c such that
*> the vector
*>                 [ s*x ]
*>          xhat = [  c  ]
*> is an approximate singular vector of
*>                 [ L      0  ]
*>          Lhat = [ w**T gamma ]
*> in the sense that
*>          twonorm(Lhat*xhat) = sestpr.
*>
*> Depending on JOB, an estimate for the largest or smallest singular
*> value is computed.
*>
*> Note that [s c]**T and sestpr**2 is an eigenpair of the system
*>
*>     diag(sest*sest, 0) + [alpha  gamma] * [ alpha ]
*>                                           [ gamma ]
*>
*> where  alpha =  x**T*w.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOB
*> \verbatim
*>          JOB is INTEGER
*>          = 1: an estimate for the largest singular value is computed.
*>          = 2: an estimate for the smallest singular value is computed.
*> \endverbatim
*>
*> \param[in] J
*> \verbatim
*>          J is INTEGER
*>          Length of X and W
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is REAL array, dimension (J)
*>          The j-vector x.
*> \endverbatim
*>
*> \param[in] SEST
*> \verbatim
*>          SEST is REAL
*>          Estimated singular value of j by j matrix L
*> \endverbatim
*>
*> \param[in] W
*> \verbatim
*>          W is REAL array, dimension (J)
*>          The j-vector w.
*> \endverbatim
*>
*> \param[in] GAMMA
*> \verbatim
*>          GAMMA is REAL
*>          The diagonal element gamma.
*> \endverbatim
*>
*> \param[out] SESTPR
*> \verbatim
*>          SESTPR is REAL
*>          Estimated singular value of (j+1) by (j+1) matrix Lhat.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is REAL
*>          Sine needed in forming xhat.
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*>          C is REAL
*>          Cosine needed in forming xhat.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            J, JOB
      REAL               C, GAMMA, S, SEST, SESTPR
*     ..
*     .. Array Arguments ..
      REAL               W( J ), X( J )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
      REAL               HALF, FOUR
      PARAMETER          ( HALF = 0.5E0, FOUR = 4.0E0 )
*     ..
*     .. Local Scalars ..
      REAL               ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
     $                   NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN, SQRT
*     ..
*     .. External Functions ..
      REAL               SDOT, SLAMCH
      EXTERNAL           SDOT, SLAMCH
*     ..
*     .. Executable Statements ..
*
      EPS = SLAMCH( 'Epsilon' )
      ALPHA = SDOT( J, X, 1, W, 1 )
*
      ABSALP = ABS( ALPHA )
      ABSGAM = ABS( GAMMA )
      ABSEST = ABS( SEST )
*
      IF( JOB.EQ.1 ) THEN
*
*        Estimating largest singular value
*
*        special cases
*
         IF( SEST.EQ.ZERO ) THEN
            S1 = MAX( ABSGAM, ABSALP )
            IF( S1.EQ.ZERO ) THEN
               S = ZERO
               C = ONE
               SESTPR = ZERO
            ELSE
               S = ALPHA / S1
               C = GAMMA / S1
               TMP = SQRT( S*S+C*C )
               S = S / TMP
               C = C / TMP
               SESTPR = S1*TMP
            END IF
            RETURN
         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
            S = ONE
            C = ZERO
            TMP = MAX( ABSEST, ABSALP )
            S1 = ABSEST / TMP
            S2 = ABSALP / TMP
            SESTPR = TMP*SQRT( S1*S1+S2*S2 )
            RETURN
         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
            S1 = ABSGAM
            S2 = ABSEST
            IF( S1.LE.S2 ) THEN
               S = ONE
               C = ZERO
               SESTPR = S2
            ELSE
               S = ZERO
               C = ONE
               SESTPR = S1
            END IF
            RETURN
         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
            S1 = ABSGAM
            S2 = ABSALP
            IF( S1.LE.S2 ) THEN
               TMP = S1 / S2
               S = SQRT( ONE+TMP*TMP )
               SESTPR = S2*S
               C = ( GAMMA / S2 ) / S
               S = SIGN( ONE, ALPHA ) / S
            ELSE
               TMP = S2 / S1
               C = SQRT( ONE+TMP*TMP )
               SESTPR = S1*C
               S = ( ALPHA / S1 ) / C
               C = SIGN( ONE, GAMMA ) / C
            END IF
            RETURN
         ELSE
*
*           normal case
*
            ZETA1 = ALPHA / ABSEST
            ZETA2 = GAMMA / ABSEST
*
            B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
            C = ZETA1*ZETA1
            IF( B.GT.ZERO ) THEN
               T = C / ( B+SQRT( B*B+C ) )
            ELSE
               T = SQRT( B*B+C ) - B
            END IF
*
            SINE = -ZETA1 / T
            COSINE = -ZETA2 / ( ONE+T )
            TMP = SQRT( SINE*SINE+COSINE*COSINE )
            S = SINE / TMP
            C = COSINE / TMP
            SESTPR = SQRT( T+ONE )*ABSEST
            RETURN
         END IF
*
      ELSE IF( JOB.EQ.2 ) THEN
*
*        Estimating smallest singular value
*
*        special cases
*
         IF( SEST.EQ.ZERO ) THEN
            SESTPR = ZERO
            IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
               SINE = ONE
               COSINE = ZERO
            ELSE
               SINE = -GAMMA
               COSINE = ALPHA
            END IF
            S1 = MAX( ABS( SINE ), ABS( COSINE ) )
            S = SINE / S1
            C = COSINE / S1
            TMP = SQRT( S*S+C*C )
            S = S / TMP
            C = C / TMP
            RETURN
         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
            S = ZERO
            C = ONE
            SESTPR = ABSGAM
            RETURN
         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
            S1 = ABSGAM
            S2 = ABSEST
            IF( S1.LE.S2 ) THEN
               S = ZERO
               C = ONE
               SESTPR = S1
            ELSE
               S = ONE
               C = ZERO
               SESTPR = S2
            END IF
            RETURN
         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
            S1 = ABSGAM
            S2 = ABSALP
            IF( S1.LE.S2 ) THEN
               TMP = S1 / S2
               C = SQRT( ONE+TMP*TMP )
               SESTPR = ABSEST*( TMP / C )
               S = -( GAMMA / S2 ) / C
               C = SIGN( ONE, ALPHA ) / C
            ELSE
               TMP = S2 / S1
               S = SQRT( ONE+TMP*TMP )
               SESTPR = ABSEST / S
               C = ( ALPHA / S1 ) / S
               S = -SIGN( ONE, GAMMA ) / S
            END IF
            RETURN
         ELSE
*
*           normal case
*
            ZETA1 = ALPHA / ABSEST
            ZETA2 = GAMMA / ABSEST
*
            NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
     $              ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
*
*           See if root is closer to zero or to ONE
*
            TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
            IF( TEST.GE.ZERO ) THEN
*
*              root is close to zero, compute directly
*
               B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
               C = ZETA2*ZETA2
               T = C / ( B+SQRT( ABS( B*B-C ) ) )
               SINE = ZETA1 / ( ONE-T )
               COSINE = -ZETA2 / T
               SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
            ELSE
*
*              root is closer to ONE, shift by that amount
*
               B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
               C = ZETA1*ZETA1
               IF( B.GE.ZERO ) THEN
                  T = -C / ( B+SQRT( B*B+C ) )
               ELSE
                  T = B - SQRT( B*B+C )
               END IF
               SINE = -ZETA1 / T
               COSINE = -ZETA2 / ( ONE+T )
               SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
            END IF
            TMP = SQRT( SINE*SINE+COSINE*COSINE )
            S = SINE / TMP
            C = COSINE / TMP
            RETURN
*
         END IF
      END IF
      RETURN
*
*     End of SLAIC1
*
      END


      FUNCTION rj(x,y,z,p)
      REAL rj,p,x,y,z,ERRTOL,TINY,BIG,C1,C2,C3,C4,C5,C6,C7,C8
      PARAMETER (ERRTOL=.05,TINY=2.5e-13,BIG=9.E11,C1=3./14.,C2=1./3.,
     *C3=3./22.,C4=3./26.,C5=.75*C3,C6=1.5*C4,C7=.5*C2,C8=C3+C3)
CU    USES rc,rf
      REAL a,alamb,alpha,ave,b,beta,delp,delx,dely,delz,ea,eb,ec,ed,ee,
     *fac,pt,rcx,rho,sqrtx,sqrty,sqrtz,sum,tau,xt,yt,zt,rc,rf
      if(min(x,y,z).lt.0..or.min(x+y,x+z,y+z,abs(p)).lt.TINY.or.max(x,y,
     *z,abs(p)).gt.BIG)pause 'invalid arguments in rj'
      sum=0.
      fac=1.
      if(p.gt.0.)then
        xt=x
        yt=y
        zt=z
        pt=p
      else
        xt=min(x,y,z)
        zt=max(x,y,z)
        yt=x+y+z-xt-zt
        a=1./(yt-p)
        b=a*(zt-yt)*(yt-xt)
        pt=yt+b
        rho=xt*zt/yt
        tau=p*pt/yt
        rcx=rc(rho,tau)
      endif
1     continue
        sqrtx=sqrt(xt)
        sqrty=sqrt(yt)
        sqrtz=sqrt(zt)
        alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
        alpha=(pt*(sqrtx+sqrty+sqrtz)+sqrtx*sqrty*sqrtz)**2
        beta=pt*(pt+alamb)**2
        sum=sum+fac*rc(alpha,beta)
        fac=.25*fac
        xt=.25*(xt+alamb)
        yt=.25*(yt+alamb)
        zt=.25*(zt+alamb)
        pt=.25*(pt+alamb)
        ave=.2*(xt+yt+zt+pt+pt)
        delx=(ave-xt)/ave
        dely=(ave-yt)/ave
        delz=(ave-zt)/ave
        delp=(ave-pt)/ave
      if(max(abs(delx),abs(dely),abs(delz),abs(delp)).gt.ERRTOL)goto 1
      ea=delx*(dely+delz)+dely*delz
      eb=delx*dely*delz
      ec=delp**2
      ed=ea-3.*ec
      ee=eb+2.*delp*(ea-ec)
      rj=3.*sum+fac*(1.+ed*(-C1+C5*ed-C6*ee)+eb*(C7+delp*(-C8+delp*C4))+
     *delp*ea*(C2-delp*C3)-C2*delp*ec)/(ave*sqrt(ave))
      if (p.le.0.) rj=a*(b*rj+3.*(rcx-rf(xt,yt,zt)))
      return
      END

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


program test_rkmethod
  use RKMethod, only: dagrt_state_type, &
    timestep_initialize => initialize, &
    timestep_run => run, &
    timestep_shutdown => shutdown

  implicit none

  type(dagrt_state_type), target :: state
  type(dagrt_state_type), pointer :: state_ptr

  real*8, dimension(2) :: initial_condition, true_sol
  integer, dimension(2) :: ntrips

  integer run_count
  real*8 t_fin
  parameter (run_count=2, t_fin=1d0)

  real*8, dimension(run_count):: dt_values, errors

  real*8 est_order, min_order

  integer stderr
  parameter(stderr=0)

  integer istep, irun

  ! start code ----------------------------------------------------------------

  state_ptr => state

  initial_condition(1) = 2
  initial_condition(2) = 2.3

  ntrips(1) = 20
  ntrips(2) = 50

  do irun = 1,run_count
    dt_values(irun) = t_fin/ntrips(irun)

    call timestep_initialize( &
      dagrt_state=state_ptr, &
      state_y=initial_condition, &
      dagrt_t=0d0, &
      dagrt_dt=dt_values(irun))

    do istep = 1,ntrips(irun)
      call timestep_run(dagrt_state=state_ptr)
      if (associated(state%ret_state_y)) then
        write(*,*) state%ret_state_y
      endif
    enddo

    true_sol = initial_condition * exp(-2*state%ret_time_y)
    errors(irun) = sqrt(sum((true_sol-state%ret_state_y)**2))

    write(*,*) errors

    call timestep_shutdown(dagrt_state=state_ptr)
    write(*,*) 'done'
  enddo

  min_order = MIN_ORDER
  est_order = log(errors(2)/errors(1))/log(dt_values(2)/dt_values(1))

  write(*,*) 'estimated order:', est_order
  if (est_order < min_order) then
    write(stderr,*) 'ERROR: achieved order too low:', est_order, ' < ', &
        min_order
  endif

end program


    program demo_aint
    use, intrinsic :: iso_fortran_env, only : real32, real64
    implicit none
    real(kind=real32) :: x4
    real(kind=real64) :: x8

       x4 = 4.3210_real32
       x8 = 4.3210_real64
       print *, aint(x4), aint(x8)
       print *
       ! elemental
       print *,aint([ &
        &  -2.7,  -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &
        &  0.0,   &
        &  +0.5,  +1.0, +1.5, +2.0, +2.2, +2.5, +2.7  ])

    end program demo_aint


program array_section
  implicit none

 REAL(kind=8) :: A( 10,10)
 INTEGER      :: p3D(15,15,15)

 ! Initialization
 A = 0.0d0
 p3D = 0

 ! array sections
 A(2:5,3:7:2) = 4.0d0
 p3D(12:15,5:8,1:15:8) = 4837

 print*, 'A = ', A
 print*, 'p3D = ', p3D

end program array_section


      SUBROUTINE SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To transform a SISO (single-input single-output) system [A,B;C,D]
C     by mirroring its unstable poles and zeros in the boundary of the
C     stability domain, thus preserving the frequency response of the
C     system, but making it stable and minimum phase. Specifically, for
C     a continuous-time system, the positive real parts of its poles
C     and zeros are exchanged with their negatives. Discrete-time
C     systems are first converted to continuous-time systems using a
C     bilinear transformation, and finally converted back.
C
C     ARGUMENTS
C
C     Input/Output parameters
C
C     DISCFL  (input) INTEGER
C             Indicates the type of the system, as follows:
C             = 0: continuous-time system;
C             = 1: discrete-time system.
C
C     N       (input/output) INTEGER
C             On entry, the order of the original system.  N >= 0.
C             On exit, the order of the transformed, minimal system.
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 original system matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed matrix A, in an upper Hessenberg form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the original system
C             vector B.
C             On exit, this array contains the transformed vector B.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the original system
C             vector C.
C             On exit, this array contains the transformed vector C.
C             The first N-1 elements are zero (for the exit value of N).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (1)
C             On entry, this array must contain the original system
C             scalar D.
C             On exit, this array contains the transformed scalar D.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (max(2,N+1))
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(N*N + 5*N, 6*N + 1 + min(1,N)).
C             For optimum performance LDWORK should be larger.
C
C     Error indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the discrete --> continuous transformation cannot
C                   be made;
C             = 2:  if the system poles cannot be found;
C             = 3:  if the inverse system cannot be found, i.e., D is
C                   (close to) zero;
C             = 4:  if the system zeros cannot be found;
C             = 5:  if the state-space representation of the new
C                   transfer function T(s) cannot be found;
C             = 6:  if the continuous --> discrete transformation cannot
C                   be made.
C
C     METHOD
C
C     First, if the system is discrete-time, it is transformed to
C     continuous-time using alpha = beta = 1 in the bilinear
C     transformation implemented in the SLICOT routine AB04MD.
C     Then the eigenvalues of A, i.e., the system poles, are found.
C     Then, the inverse of the original system is found and its poles,
C     i.e., the system zeros, are evaluated.
C     The obtained system poles Pi and zeros Zi are checked and if a
C     positive real part is detected, it is exchanged by -Pi or -Zi.
C     Then the polynomial coefficients of the transfer function
C     T(s) = Q(s)/P(s) are found.
C     The state-space representation of T(s) is then obtained.
C     The system matrices B, C, D are scaled so that the transformed
C     system has the same system gain as the original system.
C     If the original system is discrete-time, then the result (which is
C     continuous-time) is converted back to discrete-time.
C
C     CONTRIBUTORS
C
C     Asparuh Markovski, Technical University of Sofia, July 2003.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003.
C
C     KEYWORDS
C
C     Bilinear transformation, stability, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            DISCFL, INFO, LDA, LDWORK, N
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( * ), C( * ), D( * ), DWORK( * )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IDW1, IDW2, IDW3, IMP, IMZ, INFO2, IWA, IWP,
     $                   IWPS, IWQ, IWQS, LDW1, MAXWRK, REP, REZ
      DOUBLE PRECISION   RCOND, SCALB, SCALC, SCALD
C     ..
C     .. Local Arrays ..
      INTEGER            INDEX(1)
C     ..
C     .. External Subroutines ..
      EXTERNAL           AB04MD, AB07ND, DCOPY, DGEEV, DLACPY, DSCAL,
     $                   MC01PD, TD04AD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, MAX, MIN, SIGN, SQRT
C
C     Test input parameters and workspace.
C
      INFO = 0
      IF ( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN
         INFO = -1
      ELSE IF ( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF ( LDWORK.LT.MAX( N*N + 5*N, 6*N + 1 + MIN( 1, N ) ) ) THEN
         INFO = -10
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB10ZP', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Workspace usage 1.
C
      REP  = 1
      IMP  = REP + N
      REZ  = IMP + N
      IMZ  = REZ + N
      IWA  = REZ
      IDW1 = IWA + N*N
      LDW1 = LDWORK - IDW1 + 1
C
C     1. Discrete --> continuous transformation if needed.
C
      IF ( DISCFL.EQ.1 ) THEN
C
C        Workspace:  need    max(1,N);
C                            prefer  larger.
C
         CALL AB04MD( 'D', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1,
     $                D, 1, IWORK, DWORK, LDWORK, INFO2 )
         IF ( INFO2.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
         MAXWRK = INT( DWORK(1) )
      ELSE
         MAXWRK = 0
      END IF
C
C     2. Determine the factors for restoring system gain.
C
      SCALD = D(1)
      SCALC = SQRT( ABS( SCALD ) )
      SCALB = SIGN( SCALC, SCALD )
C
C     3. Find the system poles, i.e., the eigenvalues of A.
C        Workspace:  need    N*N + 2*N + 3*N;
C                            prefer  larger.
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IWA), N )
C
      CALL DGEEV( 'N', 'N', N, DWORK(IWA), N, DWORK(REP), DWORK(IMP),
     $            DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1,
     $            INFO2 )
      IF ( INFO2.NE.0 ) THEN
         INFO = 2
         RETURN
      END IF
      MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) )
C
C     4. Compute the inverse system [Ai, Bi; Ci, Di].
C        Workspace:  need    N*N + 2*N + 4;
C                            prefer  larger.
C
      CALL AB07ND( N, 1, A, LDA, B, LDA, C, 1, D, 1, RCOND, IWORK,
     $             DWORK(IDW1), LDW1, INFO2 )
      IF ( INFO2.NE.0 ) THEN
         INFO = 3
         RETURN
      END IF
      MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) )
C
C     5. Find the system zeros, i.e., the eigenvalues of Ai.
C        Workspace:  need    4*N + 3*N;
C                            prefer  larger.
C
      IDW1 = IMZ + N
      LDW1 = LDWORK - IDW1 + 1
C
      CALL DGEEV( 'N', 'N', N, A, LDA, DWORK(REZ), DWORK(IMZ),
     $            DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1,
     $            INFO2 )
      IF ( INFO2.NE.0 ) THEN
         INFO = 4
         RETURN
      END IF
      MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) )
C
C     6. Exchange the zeros and the poles with positive real parts with
C        their negatives.
C
      DO 10 I = 0, N - 1
         IF ( DWORK(REP+I).GT.ZERO )
     $      DWORK(REP+I) = -DWORK(REP+I)
         IF ( DWORK(REZ+I).GT.ZERO )
     $      DWORK(REZ+I) = -DWORK(REZ+I)
   10 CONTINUE
C
C     Workspace usage 2.
C
      IWP  = IDW1
      IDW2 = IWP + N + 1
      IWPS = 1
C
C     7. Construct the nominator and the denominator
C        of the system transfer function T( s ) = Q( s )/P( s ).
C     8. Rearrange the coefficients in Q(s) and P(s) because
C        MC01PD subroutine produces them in increasing powers of s.
C        Workspace:  need    6*N + 2.
C
      CALL MC01PD( N, DWORK(REP), DWORK(IMP), DWORK(IWP), DWORK(IDW2),
     $             INFO2 )
      CALL DCOPY( N+1, DWORK(IWP), -1, DWORK(IWPS), 1 )
C
C     Workspace usage 3.
C
      IWQ  = IDW1
      IWQS = IWPS + N + 1
      IDW3 = IWQS + N + 1
C
      CALL MC01PD( N, DWORK(REZ), DWORK(IMZ), DWORK(IWQ), DWORK(IDW2),
     $             INFO2 )
      CALL DCOPY( N+1, DWORK(IWQ), -1, DWORK(IWQS), 1 )
C
C     9. Make the conversion T(s) --> [A, B; C, D].
C        Workspace:  need    2*N + 2 + N + max(N,3);
C                            prefer  larger.
C
      INDEX(1) = N
      CALL TD04AD( 'R', 1, 1, INDEX, DWORK(IWPS), 1, DWORK(IWQS), 1, 1,
     $             N, A, LDA, B, LDA, C, 1, D, 1, -ONE, IWORK,
     $             DWORK(IDW3), LDWORK-IDW3+1, INFO2 )
      IF ( INFO2.NE.0 ) THEN
         INFO = 5
         RETURN
      END IF
      MAXWRK = MAX( MAXWRK, INT( DWORK(IDW3) + IDW3 - 1 ) )
C
C    10. Scale the transformed system to the previous gain.
C
      IF ( N.GT.0 ) THEN
         CALL DSCAL( N, SCALB, B, 1 )
         C(N) = SCALC*C(N)
      END IF
C
      D(1) = SCALD
C
C     11. Continuous --> discrete transformation if needed.
C
      IF ( DISCFL.EQ.1 ) THEN
         CALL AB04MD( 'C', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1,
     $                D, 1, IWORK, DWORK, LDWORK, INFO2 )

         IF ( INFO2.NE.0 ) THEN
            INFO = 6
            RETURN
         END IF
      END IF
C
      DWORK(1) = MAXWRK
      RETURN
C
C *** Last line of SB10ZP ***
      END