      SUBROUTINE NF01AY( NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, LDZ,
     $                   Y, LDY, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To calculate the output of a set of neural networks with the
C     structure
C
C             - tanh(w1'*z+b1) -
C           /      :             \
C         z ---    :           --- sum(ws(i)*...)+ b(n+1)  --- y,
C           \      :             /
C             - tanh(wn'*z+bn) -
C
C     given the input z and the parameter vectors wi, ws, and b,
C     where z, w1, ..., wn are vectors of length NZ, ws is a vector
C     of length n, b(1), ..., b(n+1) are scalars, and n is called the
C     number of neurons in the hidden layer, or just number of neurons.
C     Such a network is used for each L output variables.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NSMP    (input) INTEGER
C             The number of training samples.  NSMP >= 0.
C
C     NZ      (input) INTEGER
C             The length of each input sample.  NZ >= 0.
C
C     L       (input) INTEGER
C             The length of each output sample.  L >= 0.
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters needed.
C             IPAR(1) must contain the number of neurons, n, per output
C             variable, denoted NN in the sequel.  NN >= 0.
C
C     LIPAR   (input) INTEGER
C             The length of the vector IPAR.  LIPAR >= 1.
C
C     WB      (input) DOUBLE PRECISION array, dimension (LWB)
C             The leading (NN*(NZ+2)+1)*L part of this array must
C             contain the weights and biases of the network. This vector
C             is partitioned into L vectors of length NN*(NZ+2)+1,
C             WB = [ wb(1), ..., wb(L) ]. Each wb(k), k = 1, ..., L,
C             corresponds to one output variable, and has the structure
C             wb(k) = [ w1(1), ..., w1(NZ), ..., wn(1), ..., wn(NZ),
C                       ws(1), ..., ws(n), b(1), ..., b(n+1) ],
C             where wi(j) are the weights of the hidden layer,
C             ws(i) are the weights of the linear output layer, and
C             b(i) are the biases, as in the scheme above.
C
C     LWB     (input) INTEGER
C             The length of the array WB.
C             LWB >= ( NN*(NZ + 2) + 1 )*L.
C
C     Z       (input) DOUBLE PRECISION array, dimension (LDZ, NZ)
C             The leading NSMP-by-NZ part of this array must contain the
C             set of input samples,
C             Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ).
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1,NSMP).
C
C     Y       (output) DOUBLE PRECISION array, dimension (LDY, L)
C             The leading NSMP-by-L part of this array contains the set
C             of output samples,
C             Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ).
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= MAX(1,NSMP).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 2*NN.
C             For better 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
C     METHOD
C
C     BLAS routines are used to compute the matrix-vector products.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Oct. 2000, during a stay at University of Twente, NL.
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Input output description, neural network, nonlinear system,
C     simulation, system response.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDWORK, LDY, LDZ, LIPAR, LWB, NSMP, NZ
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), WB(*), Y(LDY,*), Z(LDZ,*)
      INTEGER           IPAR(*)
C     .. Local Scalars ..
      LOGICAL           LAST
      INTEGER           I, IB, J, K, LDWB, LJ, LK, M, MF, NN, NV, WS
      DOUBLE PRECISION  BIGNUM, DF, SMLNUM, TMP
C     .. External Functions ..
      DOUBLE PRECISION  DDOT, DLAMCH
      EXTERNAL          DDOT, DLAMCH
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DLABAD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, EXP, LOG, MAX, MIN, MOD
C     ..
C     .. Executable Statements ..
C
      INFO = 0
      NN   = IPAR(1)
      LDWB = NN*( NZ + 2 ) + 1
      IF ( NSMP.LT.0 ) THEN
         INFO = -1
      ELSEIF ( NZ.LT.0 ) THEN
         INFO = -2
      ELSEIF ( L.LT.0 ) THEN
         INFO = -3
      ELSEIF ( NN.LT.0 ) THEN
         INFO = -4
      ELSEIF ( LIPAR.LT.1 ) THEN
         INFO = -5
      ELSEIF ( LWB.LT.LDWB*L ) THEN
         INFO = -7
      ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN
         INFO = -9
      ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN
         INFO = -11
      ELSEIF ( LDWORK.LT.2*NN ) THEN
          INFO = -13
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01AY', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( MIN( NSMP, L ).EQ.0 )
     $   RETURN
C
C     Set parameters to avoid overflows and increase accuracy for
C     extreme values.
C
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = LOG( SMLNUM )
      BIGNUM = LOG( BIGNUM )
C
      WS = NZ*NN + 1
      IB = WS + NN - 1
      LK = 0
      IF ( MIN( NZ, NN ).EQ.0 ) THEN
         NV = 2
      ELSE
         NV = ( LDWORK - NN )/NN
      END IF
C
      IF ( NV.GT.2 ) THEN
         MF   = ( NSMP/NV )*NV
         LAST = MOD( NSMP, NV ).NE.0
C
C        Some BLAS 3 calculations can be used.
C
         DO 70 K = 0, L - 1
            TMP = WB(IB+NN+1+LK)
C
            DO 10 J = 1, NN
               DWORK(J) = TWO*WB(IB+J+LK)
   10       CONTINUE
C
            DO 40 I = 1, MF, NV
C
C              Compute -2*[w1 w2 ... wn]'*Z', where
C              Z = [z(i)';...; z(i+NV-1)'].
C
               CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO,
     $                     WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1),
     $                     NN )
               LJ = NN
C
               DO 30 M = 1, NV
                  DO 20 J = 1, NN
C
C                    Compute tanh(wj'*z(i) + bj), j = 1:n.
C
                     LJ = LJ + 1
                     DF = DWORK(LJ) - DWORK(J)
                     IF ( ABS( DF ).GE.BIGNUM ) THEN
                        IF ( DF.GT.ZERO ) THEN
                           DWORK(LJ) = -ONE
                        ELSE
                           DWORK(LJ) = ONE
                        END IF
                     ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN
                        DWORK(LJ) = ZERO
                     ELSE
                        DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE
                     END IF
   20             CONTINUE
C
   30          CONTINUE
C
               Y(I, K+1) = TMP
               CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 )
               CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN,
     $                     WB(WS+LK), 1, ONE, Y(I, K+1), 1 )
   40       CONTINUE
C
            IF ( LAST ) THEN
C
C              Process the last samples.
C
               NV = NSMP - MF
               I  = MF + 1
C
C              Compute -2*[w1 w2 ... wn]'*Z', where
C              Z = [z(i)';...; z(NSMP)'].
C
               CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO,
     $                     WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1),
     $                     NN )
               LJ = NN
C
               DO 60 M = 1, NV
                  DO 50 J = 1, NN
C
C                    Compute tanh(wj'*z(i) + bj), j = 1:n.
C
                     LJ = LJ + 1
                     DF = DWORK(LJ) - DWORK(J)
                     IF ( ABS( DF ).GE.BIGNUM ) THEN
                        IF ( DF.GT.ZERO ) THEN
                           DWORK(LJ) = -ONE
                        ELSE
                           DWORK(LJ) = ONE
                        END IF
                     ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN
                        DWORK(LJ) = ZERO
                     ELSE
                        DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE
                     END IF
   50             CONTINUE
C
   60          CONTINUE
C
               Y(I, K+1) = TMP
               IF ( NV.GT.1 )
     $            CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 )
               CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN,
     $                     WB(WS+LK), 1, ONE, Y(I, K+1), 1 )
            END IF
C
            LK = LK + LDWB
   70    CONTINUE
C
      ELSE
C
C        BLAS 2 calculations only can be used.
C
         DO 110 K = 0, L - 1
            TMP = WB(IB+NN+1+LK)
C
            DO 80 J = 1, NN
               DWORK(J) = TWO*WB(IB+J+LK)
   80       CONTINUE
C
            DO 100 I = 1, NSMP
C
C              Compute -2*[w1 w2 ... wn]'*z(i).
C
               IF ( NZ.EQ.0 ) THEN
                  DWORK(NN+1) = ZERO
                  CALL DCOPY( NN, DWORK(NN+1), 0, DWORK(NN+1), 1 )
               ELSE
                  CALL DGEMV( 'Transpose', NZ, NN, -TWO, WB(1+LK), NZ,
     $                        Z(I,1), LDZ, ZERO, DWORK(NN+1), 1 )
               END IF
C
               DO 90 J = NN + 1, 2*NN
C
C                 Compute tanh(wj'*z(i) + bj), j = 1:n.
C
                  DF = DWORK(J) - DWORK(J-NN)
                  IF ( ABS( DF ).GE.BIGNUM ) THEN
                     IF ( DF.GT.ZERO ) THEN
                        DWORK(J) = -ONE
                     ELSE
                        DWORK(J) = ONE
                     END IF
                  ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN
                     DWORK(J) = ZERO
                  ELSE
                     DWORK(J) = TWO/( ONE + EXP( DF ) ) - ONE
                  END IF
   90          CONTINUE
C
               Y(I, K+1) = DDOT( NN, WB(WS+LK), 1, DWORK(NN+1), 1 ) +
     $                     TMP
  100       CONTINUE
C
            LK = LK + LDWB
  110    CONTINUE
C
      END IF
      RETURN
C
C *** Last line of NF01AY ***
      END


      SUBROUTINE TRANHS (HS, XFORM, A,B,C,D)

C  TRANHS accepts a 3D half-space, described as a point (on the
C  boundary plane) and normal vector, applies a transform, and
C  returns the coefficients of the new boundary plane, such that
C  x,y,z is in the new half-space iff A*x + B*y + C*z + D .GE. 0

C  Input parameters:
C    HS(1,2,3)  : x,y,z coordinates of point of half-space
C    HS(4,5,6)  : x,y,z coordinates of normal vector of half-space
C    XFORM      : transformation matrix
C  Output parameters:
C    A,B,C,D    : coefficients of new boundary plane.

      REAL    HS(6), XFORM(4,4), TMPX,TMPY,TMPZ, A,B,C,D
      REAL    VECAX,VECAY,VECAZ, VECBX,VECBY,VECBZ
      REAL    OLDX(4),OLDY(4),OLDZ(4), NEWX(4),NEWY(4),NEWZ(4)

C  VECA is a unit vector orthogonal to the normal vector
      CALL PRPV1 (HS(4),HS(5),HS(6), TMPX, TMPY, TMPZ)
      CALL VEC1  (TMPX, TMPY, TMPZ,  VECAX,VECAY,VECAZ)
C  VECB is a unit vector orthogonal to the normal vector and VECA
      CALL CROSSP (VECAX,VECAY,VECAZ, HS(4),HS(5),HS(6),
     1             TMPX, TMPY, TMPZ)
      CALL VEC1 (TMPX,TMPY,TMPZ, VECBX,VECBY,VECBZ)

C  OLD-1, OLD-2, and OLD-3 are all in the (old) boundary plane,
C  forming an L-shape.
      OLDX(1) = HS(1) + VECAX
      OLDY(1) = HS(2) + VECAY
      OLDZ(1) = HS(3) + VECAZ

      OLDX(2) = HS(1) + VECBX
      OLDY(2) = HS(2) + VECBY
      OLDZ(2) = HS(3) + VECBZ

      OLDX(3) = HS(1)
      OLDY(3) = HS(2)
      OLDZ(3) = HS(3)

C  OLD-4 is a point inside the (old) half-space
      OLDX(4) = HS(1) + HS(4)
      OLDY(4) = HS(2) + HS(5)
      OLDZ(4) = HS(3) + HS(6)

C  transform 4 old points to 4 new points
      CALL ARRTP3 (4, OLDX,OLDY,OLDZ, XFORM, NEWX,NEWY,NEWZ)

C  first 3 new points define new boundary plane
      CALL PT3PL (NEWX,NEWY,NEWZ, A,B,C,D)

C  check that parity is OK - if not, negate co-efficients
      IF (A*NEWX(4) + B*NEWY(4) + C*NEWZ(4) + D .LT. 0) THEN
         A = -A
         B = -B
         C = -C
         D = -D
      ENDIF

      END


      SUBROUTINE stiff(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs)
      INTEGER n,NMAX,MAXTRY
      REAL eps,hdid,hnext,htry,x,dydx(n),y(n),yscal(n),SAFETY,GROW,
     *PGROW,SHRNK,PSHRNK,ERRCON,GAM,A21,A31,A32,A2X,A3X,C21,C31,C32,C41,
     *C42,C43,B1,B2,B3,B4,E1,E2,E3,E4,C1X,C2X,C3X,C4X
      EXTERNAL derivs
      PARAMETER (NMAX=50,SAFETY=0.9,GROW=1.5,PGROW=-.25,SHRNK=0.5,
     *PSHRNK=-1./3.,ERRCON=.1296,MAXTRY=40)
      PARAMETER (GAM=1./2.,A21=2.,A31=48./25.,A32=6./25.,C21=-8.,
     *C31=372./25.,C32=12./5.,C41=-112./125.,C42=-54./125.,C43=-2./5.,
     *B1=19./9.,B2=1./2.,B3=25./108.,B4=125./108.,E1=17./54.,E2=7./36.,
     *E3=0.,E4=125./108.,C1X=1./2.,C2X=-3./2.,C3X=121./50.,C4X=29./250.,
     *A2X=1.,A3X=3./5.)
CU    USES derivs,jacobn,lubksb,ludcmp
      INTEGER i,j,jtry,indx(NMAX)
      REAL d,errmax,h,xsav,a(NMAX,NMAX),dfdx(NMAX),dfdy(NMAX,NMAX),
     *dysav(NMAX),err(NMAX),g1(NMAX),g2(NMAX),g3(NMAX),g4(NMAX),
     *ysav(NMAX)
      xsav=x
      do 11 i=1,n
        ysav(i)=y(i)
        dysav(i)=dydx(i)
11    continue
      call jacobn(xsav,ysav,dfdx,dfdy,n,NMAX)
      h=htry
      do 23 jtry=1,MAXTRY
        do 13 i=1,n
          do 12 j=1,n
            a(i,j)=-dfdy(i,j)
12        continue
          a(i,i)=1./(GAM*h)+a(i,i)
13      continue
        call ludcmp(a,n,NMAX,indx,d)
        do 14 i=1,n
          g1(i)=dysav(i)+h*C1X*dfdx(i)
14      continue
        call lubksb(a,n,NMAX,indx,g1)
        do 15 i=1,n
          y(i)=ysav(i)+A21*g1(i)
15      continue
        x=xsav+A2X*h
        call derivs(x,y,dydx)
        do 16 i=1,n
          g2(i)=dydx(i)+h*C2X*dfdx(i)+C21*g1(i)/h
16      continue
        call lubksb(a,n,NMAX,indx,g2)
        do 17 i=1,n
          y(i)=ysav(i)+A31*g1(i)+A32*g2(i)
17      continue
        x=xsav+A3X*h
        call derivs(x,y,dydx)
        do 18 i=1,n
          g3(i)=dydx(i)+h*C3X*dfdx(i)+(C31*g1(i)+C32*g2(i))/h
18      continue
        call lubksb(a,n,NMAX,indx,g3)
        do 19 i=1,n
          g4(i)=dydx(i)+h*C4X*dfdx(i)+(C41*g1(i)+C42*g2(i)+C43*g3(i))/h
19      continue
        call lubksb(a,n,NMAX,indx,g4)
        do 21 i=1,n
          y(i)=ysav(i)+B1*g1(i)+B2*g2(i)+B3*g3(i)+B4*g4(i)
          err(i)=E1*g1(i)+E2*g2(i)+E3*g3(i)+E4*g4(i)
21      continue
        x=xsav+h
        if(x.eq.xsav)pause 'stepsize not significant in stiff'
        errmax=0.
        do 22 i=1,n
          errmax=max(errmax,abs(err(i)/yscal(i)))
22      continue
        errmax=errmax/eps
        if(errmax.le.1.)then
          hdid=h
          if(errmax.gt.ERRCON)then
            hnext=SAFETY*h*errmax**PGROW
          else
            hnext=GROW*h
          endif
          return
        else
          hnext=SAFETY*h*errmax**PSHRNK
          h=sign(max(abs(hnext),SHRNK*abs(h)),h)
        endif
23    continue
      pause 'exceeded MAXTRY in stiff'
      END

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


      SUBROUTINE TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB,
     $                   C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, TOL,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute for the descriptor system (A-lambda E,B,C)
C     the orthogonal transformation matrices Q and Z such that the
C     transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in an
C     SVD (singular value decomposition) coordinate form with
C     the system matrices  Q'*A*Z and Q'*E*Z in the form
C
C                  ( A11  A12 )             ( Er  0 )
C         Q'*A*Z = (          ) ,  Q'*E*Z = (       ) ,
C                  ( A21  A22 )             (  0  0 )
C
C     where Er is an invertible diagonal matrix having on the diagonal
C     the decreasingly ordered nonzero singular values of E.
C     Optionally, the A22 matrix can be further reduced to the
C     SVD form
C
C                  ( Ar  0 )
C            A22 = (       ) ,
C                  (  0  0 )
C
C     where Ar is an invertible diagonal matrix having on the diagonal
C     the decreasingly ordered nonzero singular values of A22.
C     The left and/or right orthogonal transformations performed
C     to reduce E and A22 are accumulated.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBA    CHARACTER*1
C             = 'N':  do not reduce A22;
C             = 'R':  reduce A22 to an SVD form.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of matrices A, B, and E.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of matrices A, E, and C.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix Q'*A*Z. If JOBA = 'R', this matrix
C             is in the form
C
C                           ( A11  *   *  )
C                  Q'*A*Z = (  *   Ar  0  ) ,
C                           (  *   0   0  )
C
C             where A11 is a RANKE-by-RANKE matrix and Ar is a
C             RNKA22-by-RNKA22 invertible diagonal matrix, with
C             decresingly ordered positive diagonal elements.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix Q'*E*Z.
C
C                      ( Er  0 )
C             Q'*E*Z = (       ) ,
C                      (  0  0 )
C
C             where Er is a RANKE-by-RANKE invertible diagonal matrix
C             having on the diagonal the decreasingly ordered positive
C             singular values of E.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the input/state matrix B.
C             On exit, the leading L-by-M part of this array contains
C             the transformed matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.
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 state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,L)
C             The leading L-by-L part of this array contains the
C             orthogonal matrix Q, which is the accumulated product of
C             transformations applied to A, E, and B on the left.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= MAX(1,L).
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             The leading N-by-N part of this array contains the
C             orthogonal matrix Z, which is the accumulated product of
C             transformations applied to A, E, and C on the right.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= MAX(1,N).
C
C     RANKE   (output) INTEGER
C             The effective rank of matrix E, and thus also the order
C             of the invertible diagonal submatrix Er.
C             RANKE is computed as the number of singular values of E
C             greater than TOL*SVEMAX, where SVEMAX is the maximum
C             singular value of E.
C
C     RNKA22  (output) INTEGER
C             If JOBA = 'R', then RNKA22 is the effective rank of
C             matrix A22, and thus also the order of the invertible
C             diagonal submatrix Ar. RNKA22 is computed as the number
C             of singular values of A22 greater than TOL*SVAMAX,
C             where SVAMAX is an estimate of the maximum singular value
C             of A.
C             If JOBA = 'N', then RNKA22 is not referenced.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in determining the rank of E
C             and of A22. If TOL > 0, then singular values less than
C             TOL*SVMAX are treated as zero, where SVMAX is the maximum
C             singular value of E or an estimate of it for A and E.
C             If TOL <= 0, the default tolerance TOLDEF = EPS*L*N is
C             used instead, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH). TOL < 1.
C
C     Workspace
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(1,MIN(L,N) +
C                           MAX(3*MIN(L,N)+MAX(L,N), 5*MIN(L,N), M, P)).
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             > 0:  the QR algorithm has failed to converge when computing
C                   singular value decomposition. In this case INFO
C                   specifies how many superdiagonals did not converge.
C                   This failure is not likely to occur.
C
C     METHOD
C
C     The routine computes the singular value decomposition (SVD) of E,
C     in the form
C
C                    ( Er  0 )
C           E  = Q * (       ) * Z'
C                    (  0  0 )
C
C     and finds the largest RANKE-by-RANKE leading diagonal submatrix
C     Er whose condition number is less than 1/TOL. RANKE defines thus
C     the effective rank of matrix E.
C     If JOBA = 'R' the same reduction is performed on A22 in the
C     partitioned matrix
C
C                  ( A11  A12 )
C         Q'*A*Z = (          ) ,
C                  ( A21  A22 )
C
C     to obtain it in the form
C
C                  ( Ar  0 )
C            A22 = (       ) ,
C                  (  0  0 )
C
C     with Ar an invertible diagonal matrix.
C
C     The accumulated transformations are also applied to the rest of
C     matrices
C
C          B <- Q' * B,  C <- C * Z.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( L*L*N )  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDSSV.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 1999,
C     Feb. 2000, Oct. 2001, May 2003.
C
C     KEYWORDS
C
C     Descriptor system, matrix algebra, matrix operations,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          JOBA
      INTEGER            INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK,
     $                   LDZ, M, N, P, RNKA22, RANKE
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ),  E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            REDA
      INTEGER            I, IR1, J, KW, LA22, LN, LN2, LWR, NA22, WRKOPT
      DOUBLE PRECISION   EPSM, SVEMAX, SVLMAX, TOLDEF
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DGEMV, DGEQRF, DGELQF, DGESVD,
     $                   DLACPY, DLASET, DORMQR, DORMLQ, DSWAP, MA02AD,
     $                   MB03UD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
      REDA = LSAME( JOBA, 'R' )
C
C     Test the input parameters.
C
      INFO = 0
      WRKOPT = MIN( L, N ) +
     $         MAX( M, P, 3*MIN( L, N ) + MAX( L, N ), 5*MIN( L, N ) )
      IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN
         INFO = -1
      ELSE IF( L.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -7
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN
         INFO = -11
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -13
      ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN
         INFO = -15
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -20
      ELSE IF( LDWORK.LT.MAX( 1, WRKOPT ) ) THEN
         INFO = -22
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01ED', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( L.EQ.0 .OR. N.EQ.0 ) THEN
         IF( L.GT.0 )
     $      CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ )
         IF( N.GT.0 )
     $      CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
         DWORK(1) = ONE
         RANKE = 0
         IF( REDA ) RNKA22 = 0
         RETURN
      END IF
C
      LN = MIN( L, N )
      EPSM = DLAMCH( 'EPSILON' )
C
      TOLDEF = TOL
      IF( TOLDEF.LE.ZERO ) THEN
C
C        Use the default tolerance for rank determination.
C
         TOLDEF = EPSM * DBLE( L*N )
      END IF
C
C     Set the estimate of the maximum singular value of E to
C     max(||E||,||A||) to detect negligible A or E matrices.
C
      SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ) ,
     $              DLANGE( 'F', L, N, A, LDA, DWORK ) )
C
C     Compute the SVD of E
C
C                    ( Er  0 )
C           E = Qr * (       ) * Zr'
C                    (  0  0 )
C
C     Workspace: needed  MIN(L,N) + MAX(3*MIN(L,N)+MAX(L,N),5*MIN(L,N));
C                prefer larger.
C
      LWR = LDWORK - LN
      KW = LN + 1
C
      CALL DGESVD( 'A', 'A', L, N, E, LDE, DWORK, Q, LDQ, Z, LDZ,
     $             DWORK(KW), LWR, INFO )
      IF( INFO.GT.0 )
     $   RETURN
      WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C     Determine the rank of E.
C
      RANKE = 0
      IF( DWORK(1).GT.SVLMAX*EPSM ) THEN
         RANKE = 1
         SVEMAX = DWORK(1)
         DO 10 I = 2, LN
            IF( DWORK(I).LT.SVEMAX*TOLDEF ) GO TO 20
            RANKE = RANKE + 1
   10    CONTINUE
C
   20    CONTINUE
      END IF
C
C     Apply transformation on the rest of matrices.
C
      IF( RANKE.GT.0 ) THEN
C
C        A <-- Qr' * A * Zr.
C
         CALL DGEMM( 'Transpose', 'No transpose', L, N, L, ONE,
     $               Q, LDQ, A, LDA, ZERO, E, LDE )
         CALL DGEMM( 'No transpose', 'Transpose', L, N, N, ONE,
     $               E, LDE, Z, LDZ, ZERO, A, LDA )
C
C        B <-- Qr' * B.
C        Workspace: need   L;
C                   prefer L*M.
C
         IF( LWR.GT.L*M .AND. M.GT.0 ) THEN
C
            CALL DGEMM( 'Transpose', 'No transpose', L, M, L, ONE,
     $                  Q, LDQ, B, LDB, ZERO, DWORK(KW), L )
            CALL DLACPY( 'Full', L, M, DWORK(KW), L, B, LDB )
         ELSE
            DO 30 J = 1, M
               CALL DGEMV( 'Transpose', L, L, ONE, Q, LDQ, B(1,J), 1,
     $                     ZERO, DWORK(KW), 1 )
               CALL DCOPY( L, DWORK(KW), 1, B(1,J), 1 )
   30       CONTINUE
         END IF
C
C        C <-- C * Zr.
C        Workspace: need   N;
C                   prefer P*N.
C
         IF( LWR.GT.P*N ) THEN
C
            CALL DGEMM( 'No transpose', 'Transpose', P, N, N, ONE,
     $                  C, LDC, Z, LDZ, ZERO, DWORK(KW), MAX( 1, P ) )
            CALL DLACPY( 'Full', P, N, DWORK(KW), MAX( 1, P ), C, LDC )
         ELSE
            DO 40 I = 1, P
               CALL DGEMV( 'No transpose', N, N, ONE, Z, LDZ,
     $                     C(I,1), LDC, ZERO, DWORK(KW), 1 )
               CALL DCOPY( N, DWORK(KW), 1, C(I,1), LDC )
   40       CONTINUE
         END IF
         WRKOPT = MAX( WRKOPT, L*M, P*N )
      END IF
C
C     Reduce A22 if necessary.
C
      IF( REDA ) THEN
         LA22 = L - RANKE
         NA22 = N - RANKE
         LN2 = MIN( LA22, NA22 )
         IF( LN2.EQ.0 ) THEN
            IR1 = 1
            RNKA22 = 0
         ELSE
C
C           Compute the SVD of A22 using a storage saving approach.
C
            IR1 = RANKE + 1
            IF( LA22.GE.NA22 ) THEN
C
C              Compute the QR decomposition of A22 in the form
C
C              A22 = Q2 * ( R2 ) ,
C                         ( 0  )
C
C              where R2 is upper triangular.
C              Workspace: need   MIN(L,N) + N;
C                         prefer MIN(L,N) + N*NB.
C
               CALL DGEQRF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1),
     $                      DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Apply transformation Q2 to A, B, and Q.
C
C              A <--diag(I, Q2') * A
C              Workspace: need   MIN(L,N) + N;
C                         prefer MIN(L,N) + N*NB.
C
               CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, LN2,
     $                      A(IR1,IR1), LDA, DWORK(IR1), A(IR1,1), LDA,
     $                      DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              B <-- diag(I, Q2') * B
C              Workspace: need   MIN(L,N) + M;
C                         prefer MIN(L,N) + M*NB.
C
               IF ( M.GT.0 ) THEN
                  CALL DORMQR( 'Left', 'Transpose', LA22, M, LN2,
     $                         A(IR1,IR1), LDA, DWORK(IR1), B(IR1,1),
     $                         LDB, DWORK(KW), LWR, INFO )
                  WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
               END IF
C
C              Q <-- Q * diag(I, Q2)
C              Workspace: need   MIN(L,N) + L;
C                         prefer MIN(L,N) + L*NB.
C
               CALL DORMQR( 'Right', 'No transpose', L, LA22, LN2,
     $                       A(IR1,IR1), LDA, DWORK(IR1), Q(1,IR1), LDQ,
     $                       DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Compute the SVD of the upper triangular submatrix R2 as
C
C                               ( Ar  0 )
C                    R2 = Q2r * (       ) * Z2r' ,
C                               (  0  0 )
C
C              where Q2r is stored in E and Z2r' is stored in A22.
C              Workspace: need   MAX(1,5*MIN(L,N));
C                         prefer larger.
C
               CALL MB03UD( 'Vectors', 'Vectors', LN2, A(IR1,IR1), LDA,
     $                      E(IR1,IR1), LDE, DWORK(IR1), DWORK(KW), LWR,
     $                      INFO )
               IF( INFO.GT.0 )
     $            RETURN
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Determine the rank of A22.
C
               RNKA22 = 0
               IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN
                  RNKA22 = 1
                  DO 50 I = IR1+1, LN
                     IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 60
                     RNKA22 = RNKA22 + 1
   50             CONTINUE
C
   60             CONTINUE
               END IF
C
C              Apply transformation on the rest of matrices.
C
               IF( RNKA22.GT.0 ) THEN
C
C                 A <-- diag(I,Q2r') * A * diag(I,Zr2)
C
                  CALL DGEMM( 'Transpose', 'No transpose', LN2, RANKE,
     $                        LN2, ONE, E(IR1,IR1), LDE, A(IR1,1), LDA,
     $                        ZERO, E(IR1,1), LDE )
                  CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE,
     $                         A(IR1,1), LDA )
                  CALL DGEMM( 'No transpose', 'Transpose', RANKE, LN2,
     $                        LN2, ONE, A(1,IR1), LDA, A(IR1,IR1), LDA,
     $                        ZERO, E(1,IR1), LDE )
                  CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE,
     $                         A(1,IR1), LDA )
C
C                 B <-- diag(I,Q2r') * B
C
                  IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN
C
                     CALL DGEMM( 'Transpose', 'No transpose', LN2, M,
     $                           LN2, ONE, E(IR1,IR1), LDE, B(IR1,1),
     $                           LDB, ZERO, DWORK(KW), LN2 )
                     CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2,
     $                            B(IR1,1), LDB )
                  ELSE
                     DO 70 J = 1, M
                        CALL DGEMV( 'Transpose', LN2, LN2, ONE,
     $                              E(IR1,IR1), LDE, B( IR1,J), 1,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 )
   70                CONTINUE
                  END IF
C
C                 C <-- C * diag(I,Zr2)
C
                  IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN
C
                     CALL DGEMM( 'No transpose', 'Transpose', P, LN2,
     $                           LN2, ONE, C(1,IR1), LDC, A(IR1,IR1),
     $                           LDA, ZERO, DWORK(KW), P )
                     CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P,
     $                            C(1,IR1), LDC )
                  ELSE
                     DO 80 I = 1, P
                        CALL DGEMV( 'No transpose', LN2, LN2, ONE,
     $                              A(IR1,IR1), LDA, C(I,IR1), LDC,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC )
   80                CONTINUE
                  END IF
C
C                 Q <-- Q * diag(I, Qr2)
C
                  IF( LWR.GT.L*LN2 ) THEN
C
                     CALL DGEMM( 'No transpose', 'No transpose', L, LN2,
     $                           LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1),
     $                           LDE, ZERO, DWORK(KW), L )
                     CALL DLACPY( 'Full', L, LN2, DWORK(KW), L,
     $                            Q(1,IR1), LDQ )
                  ELSE
                     DO 90 I = 1, L
                        CALL DGEMV( 'Transpose', LN2, LN2, ONE,
     $                              E(IR1,IR1), LDE, Q(I,IR1), LDQ,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ )
   90                CONTINUE
                  END IF
C
C                 Z' <-- diag(I, Zr2') * Z'
C
                  IF( LWR.GT.N*LN2 ) THEN
C
                     CALL DGEMM( 'No transpose', 'No transpose', LN2, N,
     $                           LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1),
     $                           LDZ, ZERO, DWORK(KW), LN2 )
                     CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2,
     $                            Z(IR1,1), LDZ )
                  ELSE
                     DO 100 J = 1, N
                        CALL DGEMV( 'No transpose', LN2, LN2, ONE,
     $                              A(IR1,IR1), LDA, Z(IR1,J), 1,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 )
  100                CONTINUE
                  END IF
               END IF
            ELSE
C
C              Compute the LQ decomposition of A22 in the form
C
C                  A22 = ( L2 0 )* Z2
C
C              where L2 is lower triangular.
C              Workspace: need   MIN(L,N) + L;
C                         prefer MIN(L,N) + L*NB.
C
               CALL DGELQF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1),
     $                      DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Apply transformation Z2 to A, C, and Z.
C
C              A <-- A * diag(I, Z2')
C              Workspace: need   2*MIN(L,N);
C                         prefer MIN(L,N) + MIN(L,N)*NB.
C
               CALL DORMLQ( 'Right', 'Transpose', RANKE, NA22, LN2,
     $                      A(IR1,IR1), LDA, DWORK(IR1), A(1,IR1), LDA,
     $                      DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              C <-- C * diag(I, Z2')
C              Workspace: need   MIN(L,N) + P;
C                         prefer MIN(L,N) + P*NB.
C
               IF ( P.GT.0 ) THEN
                  CALL DORMLQ( 'Right', 'Transpose', P, NA22, LN2,
     $                         A(IR1,IR1), LDA, DWORK(IR1), C(1,IR1),
     $                         LDC, DWORK(KW), LWR, INFO )
                  WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
               END IF
C
C              Z' <-  diag(I, Z2) * Z'
C              Workspace: need   MIN(L,N) + N;
C                         prefer MIN(L,N) + N*NB.
C
               CALL DORMLQ( 'Left', 'No transpose', NA22, N, LN2,
     $                       A(IR1,IR1), LDA, DWORK(IR1), Z(IR1,1), LDZ,
     $                       DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Compute the SVD of the lower triangular submatrix L2 as
C
C                              ( Ar  0 )
C                  L2' = Z2r * (       ) * Q2r'
C                              (  0  0 )
C
C              where Q2r' is stored in E and Z2r is stored in A22.
C              Workspace: need   MAX(1,5*MIN(L,N));
C                         prefer larger.
C
               CALL MA02AD( 'Lower', LN2, LN2, A(IR1,IR1), LDA,
     $                      E(IR1,IR1), LDE )
               CALL MB03UD( 'Vectors', 'Vectors', LN2, E(IR1,IR1), LDE,
     $                      A(IR1,IR1), LDA, DWORK(IR1), DWORK(KW),
     $                      LWR, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Determine the rank of A22.
C
               RNKA22 = 0
               IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN
                  RNKA22 = 1
                  DO 110 I = IR1+1, LN
                     IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 120
                     RNKA22 = RNKA22 + 1
  110             CONTINUE
C
  120             CONTINUE
               END IF
C
C              Apply transformation on the rest of matrices.
C
               IF( RNKA22.GT.0 ) THEN
C
C                 A <-- diag(I,Q2r') * A * diag(I,Zr2)
C
                  CALL DGEMM( 'No transpose', 'No transpose', LN2,
     $                        RANKE, LN2, ONE, E(IR1,IR1), LDE,
     $                        A(IR1,1), LDA, ZERO, E(IR1,1), LDE )
                  CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE,
     $                         A(IR1,1), LDA )
                  CALL DGEMM( 'No transpose', 'No transpose', RANKE,
     $                        LN2, LN2, ONE, A(1,IR1), LDA,
     $                        A(IR1,IR1), LDA, ZERO, E(1,IR1), LDE )
                  CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE,
     $                         A(1,IR1), LDA )
C
C                 B <-- diag(I,Q2r') * B
C
                  IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN
C
                     CALL DGEMM( 'No transpose', 'No transpose', LN2, M,
     $                           LN2, ONE, E(IR1,IR1), LDE, B(IR1,1),
     $                           LDB, ZERO, DWORK(KW), LN2 )
                     CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2,
     $                            B(IR1,1), LDB )
                  ELSE
                     DO 130 J = 1, M
                        CALL DGEMV( 'No transpose', LN2, LN2, ONE,
     $                              E(IR1,IR1), LDE, B( IR1,J), 1,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 )
  130                CONTINUE
                  END IF
C
C                 C <-- C * diag(I,Zr2)
C
                  IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN
C
                     CALL DGEMM( 'No transpose', 'No transpose', P, LN2,
     $                           LN2, ONE, C(1,IR1), LDC, A(IR1,IR1),
     $                           LDA, ZERO, DWORK(KW), P )
                     CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P,
     $                            C(1,IR1), LDC )
                  ELSE
                     DO 140 I = 1, P
                        CALL DGEMV( 'Transpose', LN2, LN2, ONE,
     $                              A(IR1,IR1), LDA, C(I,IR1), LDC,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC )
  140                CONTINUE
                  END IF
C
C                 Q <-- Q * diag(I, Qr2)
C
                  IF( LWR.GT.L*LN2 ) THEN
C
                     CALL DGEMM( 'No transpose', 'Transpose', L, LN2,
     $                           LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1),
     $                           LDE, ZERO, DWORK(KW), L )
                     CALL DLACPY( 'Full', L, LN2, DWORK(KW), L,
     $                            Q(1,IR1), LDQ )
                  ELSE
                     DO 150 I = 1, L
                        CALL DGEMV( 'No transpose', LN2, LN2, ONE,
     $                              E(IR1,IR1), LDE, Q(I,IR1), LDQ,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ )
  150                CONTINUE
                  END IF
C
C                 Z' <-- diag(I, Zr2') * Z'
C
                  IF( LWR.GT.N*LN2 ) THEN
C
                     CALL DGEMM( 'Transpose', 'No transpose', LN2, N,
     $                           LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1),
     $                           LDZ, ZERO, DWORK(KW), LN2 )
                     CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2,
     $                            Z(IR1,1), LDZ )
                  ELSE
                     DO 160 J = 1, N
                        CALL DGEMV( 'Transpose', LN2, LN2, ONE,
     $                              A(IR1,IR1), LDA, Z(IR1,J), 1,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 )
  160                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
C
C     Set E.
C
      CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE )
      CALL DCOPY( RANKE, DWORK, 1, E, LDE+1 )
C
      IF( REDA ) THEN
C
C        Set A22.
C
         CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, A(IR1,IR1), LDA )
         CALL DCOPY( RNKA22, DWORK(IR1), 1, A(IR1,IR1), LDA+1 )
      END IF
C
C     Transpose Z.
C
      DO 170 I = 2, N
         CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ )
  170 CONTINUE
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TG01ED ***
      END


!> -------------------------------------------
!! Supply regression utilities to GARD
!!
!! Provides least squares regression and logistic regression
!! includes output of both the coefficients and the residual error, optionally computed with supplied weights
!!
!! --------------------------------------------
module  regression_mod
interface
    module function compute_regression(x, training_x, training_y, coefficients, y_test, error, weights, used_vars) result(y)
        implicit none
        real,    intent(in),    dimension(:)   :: x
        real,    intent(in),    dimension(:,:) :: training_x
        real,    intent(in),    dimension(:)   :: training_y
        real(8), intent(inout), dimension(:)   :: coefficients
        real,    intent(inout),                             optional :: error
        real,    intent(in),    dimension(:),               optional :: y_test
        real,    intent(inout), dimension(:),  allocatable, optional :: weights
        integer, intent(inout), dimension(:),               optional :: used_vars
        real :: y
    end function compute_regression

    module function compute_logistic_regression(x, training_x, binary_values, coefficients) result(output)
        implicit none
        real,    intent(in) :: x(:)
        real,    intent(in) :: training_x(:,:)
        real,    intent(in) :: binary_values(:)
        real(8), intent(out):: coefficients(:)
        real :: output
    end function compute_logistic_regression

end interface

end module regression_mod


!	Obtain covariance matrix of item scale parameters for an observation.
!	numcat is a vector with the number of underlying categories per category.
!	The items presented are indicated by mask.
!	means contains the corresponding means.
!	The underlying item probabilities are in probcat.
!	scales contains the scale parameters.

function covmat(numcat,mask,means,probcat,scales)
implicit none
integer,intent(in)::numcat(:)
logical,intent(in)::mask(:)
real(kind=8),intent(in)::means(:,:),probcat(:),scales(:,:)
real(kind=8)::covmat(size(scales,1),size(scales,1),size(mask))
!	cat is the category number.
!	col is the column number.
!	item is the item number.
!	nloc points to the item probability.
!	row is the row number.
integer::cat,col,item,nloc,row
!	diff contains the deviation of the scale parameters from their means.
real(kind=8)::diff(size(scales,1))
covmat=0.0_8
nloc=1
do item=1,size(mask)
	if(mask(item))then
		do cat=nloc,nloc+numcat(item)-1
			diff=scales(:,cat)-means(:,item)
			do row=1,size(diff)
				do col=1,row
					covmat(row,col,item)=covmat(row,col,item)&
						+diff(row)*diff(col)*probcat(cat)
				end do
			end do
		end do
	endif
	nloc=nloc+numcat(item)
end do
return
end function covmat


program P1834
    implicit none
    integer :: divisor, i
    integer(8) :: sum, adder
    read *, divisor
    sum = 0
    adder = divisor + 1
    do i = 2, divisor
        sum = sum + adder
        adder = adder + divisor + 1
    end do
    write (*, '(I0)') sum
end program P1834


      subroutine correlatedcb_setprob(kappa,tfinal)
      implicit none

      double precision kappa,tfinal
      integer n, m

      double precision rp2, th, lambda, wc(3,10), rps, a, w(3)

      double precision r, hmax,b,c

      double precision pi
      common /compi/ pi

      pi = 4.d0*atan(1.d0)

      call set_wind_parms(kappa,tfinal)

c     # -------------------------------------------------
c     # Setup location of cosine or Gaussians in array wc.
c     # Array 'wc' will be set in common block 'prob.i'
c     # -------------------------------------------------
c     # Locations of cosine bell or Gaussian

      th = 0
      lambda = pi/6.d0
      wc(1,1) = cos(th)*cos(lambda)
      wc(2,1) = cos(th)*sin(lambda)
      wc(3,1) = sin(th)

      th = 0
      lambda = -pi/6.d0
      wc(1,2) = cos(th)*cos(lambda)
      wc(2,2) = cos(th)*sin(lambda)
      wc(3,2) = sin(th)

c     # Number of cosine bells
      n = 2
      call set_initial_gaussian_locations(wc,n)

      r = 0.5d0
      hmax = 1.d0
      b = 0.1d0
      c = 0.9d0
      call set_initial_cosbell_parms(r,hmax,b,c)

      end


c
c*********************
c
        subroutine modobs(xr,xo,wtfunc,tfunc,errscale,ru,rt)

        complex xr(*),xo,tfunc(3),xp
        real ru,rt

        external wtfunc

        xp=tfunc(1)*xr(1)+tfunc(2)*xr(2)

        pr=real(xp)
        pi=aimag(xp)
        zr=real(xo)
        zi=aimag(xo)

        w=abs(zr-pr)/errscale
        rt = w*w
        call wtfunc(w,psiprime)
        ru=psiprime

        zr=w*zr+(1.-w)*pr

        w=abs(zi-pi)/errscale
        rt = rt + w*w
        call wt(w,psiprime)
        ru=ru+psiprime

        zi=w*zi+(1.-w)*pi

        xo=cmplx(zr,zi)

        return
        end


MODULE ISING
	IMPLICIT NONE
	REAL, PARAMETER               :: TEMP = 2.6
	INTEGER, PARAMETER            :: LSIZE = 20
	INTEGER, PARAMETER            :: NSCAN = 20, NSTEP = 5000
	INTEGER, PARAMETER            :: NSPIN = LSIZE*LSIZE
	INTEGER, PARAMETER            :: MAG1  = -NSPIN, MAG2 = NSPIN
CONTAINS

SUBROUTINE INIT_TRANSITION_PROBABILITY(tprob, temperature)
	IMPLICIT NONE
	REAL, INTENT(OUT)             :: tprob(1:8)
	REAL, INTENT(IN)              :: temperature
	INTEGER                       :: dE

	! two possible value: exp(-4J) and exp(-8J)
	DO dE = 4, 8, 4
		tprob(dE) = EXP(-dE/temperature)
	END DO
END SUBROUTINE INIT_TRANSITION_PROBABILITY

SUBROUTINE INIT_CONFIGURATION(spin, init_mag)
	IMPLICIT NONE
	INTEGER, INTENT(OUT)         :: spin(LSIZE+2,LSIZE+2)
	INTEGER, INTENT(IN)          :: init_mag
	INTEGER                      :: spin_up, spin_count
	INTEGER                    	 :: i, j

	spin_count = 0
	spin_up = (NSPIN + init_mag )/2
	DO i = 2, LSIZE + 1
		DO j = 2, LSIZE + 1
			IF ( spin_count < spin_up ) THEN
				spin_count  = spin_count + 1
				spin(i,j) = 1
			ELSE
				spin(i,j) = -1
			END IF
		END DO
	END DO

	! Periodic boundary conditon
	spin(1,:)       = spin(LSIZE+1,:)
	spin(LSIZE+2,:) = spin(2,:)
	spin(:,1)       = spin(:,LSIZE+1)
	spin(:,LSIZE+2) = spin(:,2)
END SUBROUTINE INIT_CONFIGURATION

SUBROUTINE UMBRELLA(i, j, spin, tprob, total_mag, lmag, rmag)
	IMPLICIT NONE
	INTEGER, INTENT(IN)         :: i, j
	INTEGER, INTENT(INOUT)      :: spin(LSIZE+2,LSIZE+2)
	INTEGER, INTENT(IN)         :: lmag, rmag
	REAL, INTENT(IN)            :: tprob(1:8)
	INTEGER, INTENT(INOUT)      :: total_mag

	REAL                        :: random
	INTEGER                     :: dE
	LOGICAL                     :: move

	move = .FALSE.

	dE = 2*spin(i,j)*(spin(i-1,j) + spin(i+1,j) + spin(i,j-1) + spin(i,j+1))

	IF ( dE <= 0 ) THEN
		move = .TRUE.
	ELSE
		CAll RANDOM_NUMBER(random)
		IF ( tprob(dE) > random ) THEN
			move = .TRUE.
		END IF
	END IF

	IF ( move ) THEN
		! flip the spin
		spin(i,j) = -spin(i,j)
		total_mag = total_mag + 2*spin(i,j)
		! if step outsite the window boundary, revert the step
		IF ( total_mag < lmag .OR. total_mag > rmag ) THEN
			spin(i,j) = -spin(i,j)
			total_mag = total_mag + 2*spin(i,j)
		END IF
		! Periodic boundary condition
		IF ( i == 2 )       spin(LSIZE+2,j) = spin(i,j)
		IF ( i == LSIZE+1 ) spin(1,j)       = spin(i,j)
		IF ( j == 2 )       spin(i,LSIZE+2) = spin(i,j)
		IF ( j == LSIZE+1 ) spin(i,1)       = spin(i,j)
	END IF
END SUBROUTINE UMBRELLA

SUBROUTINE CONSTRUCT_HISTOGRAM(tprob, spin, mag, iscan, histogram)
	IMPLICIT NONE
	REAL, INTENT(IN)           :: tprob(1:8)
	INTEGER, INTENT(INOUT)     :: spin(LSIZE+2, LSIZE+2), mag(NSCAN+1)
	INTEGER, INTENT(IN)        :: iscan
	REAL, INTENT(OUT)          :: histogram(mag(iscan):mag(iscan+1))

	INTEGER                    :: i, j, istep, imag
	INTEGER                    :: total_mag

	total_mag = SUM(spin(2:LSIZE+1,2:LSIZE+1))

	DO istep = 1, NSTEP
		DO i = 2, LSIZE + 1
			DO j = 2, LSIZE + 1
				CALL UMBRELLA(i, j, spin, tprob, total_mag, mag(iscan), mag(iscan+1))
				DO imag = mag(iscan), mag(iscan+1), 2
					IF (total_mag == imag) histogram(imag) = histogram(imag) + 1
				END DO
			END DO
		END DO
	END DO

	! normalization
	histogram(:) = histogram(:)/(NSTEP*NSPIN)
END SUBROUTINE CONSTRUCT_HISTOGRAM

SUBROUTINE FREE_ENE_PROFILE(mag, iscan, histogram, free_ene, memory, output)
	IMPLICIT NONE
	INTEGER, INTENT(IN)        :: mag(NSCAN+1), iscan
	REAL, INTENT(IN)           :: histogram(mag(iscan):mag(iscan+1))
	REAL, INTENT(OUT)          :: free_ene(mag(iscan):mag(iscan+1))
	REAL, INTENT(INOUT)        :: memory
	INTEGER, INTENT(IN)        :: output
	INTEGER                    :: imag

	! A(M) = -logP(M)
	free_ene(:) = -LOG(histogram(:))

	! make continuous transition
	IF ( iscan /= 1 ) THEN
		free_ene(:) = free_ene(:) + (memory - free_ene(mag(iscan)))
	END IF

	DO imag = mag(iscan), mag(iscan+1), 2
		WRITE (output, '(F15.8, 5X, E15.8)') REAL(imag)/NSPIN, free_ene(imag)
	END DO
	! store the last value to join with first point of next window
	memory = free_ene(mag(iscan+1))
END SUBROUTINE FREE_ENE_PROFILE
END MODULE ISING


!*****************************************************************************************
!> author: Jacob Williams
!  date: 12/22/2015
!  license: BSD
!
!  Root-finding routines. Used by [[ddeabm_module]].

    module root_module

    use ddeabm_kinds

    implicit none

    private

    !real parameters:
    real(wp),parameter :: zero  = 0.0_wp
    real(wp),parameter :: half  = 0.5_wp
    real(wp),parameter :: one   = 1.0_wp
    real(wp),parameter :: two   = 2.0_wp
    real(wp),parameter :: three = 3.0_wp
    real(wp),parameter :: eps   = epsilon(one)  !! original code had d1mach(4)

    abstract interface
        function func(t) result(f)  !! interface to the [[zeroin]] input function
        import :: wp
        implicit none
        real(wp),intent(in)  :: t  !! Independant variable for the function.
        real(wp)             :: f  !! The function evaluated at `t`.
        end function func
    end interface

    public :: zeroin      ! main routine

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!  Find a zero of the function \( f(x) \) in the given interval
!  \( [a_x,b_x] \) to within a tolerance \( 4 \epsilon |x| + tol \),
!  where \( \epsilon \) is the relative machine precision defined as
!  the smallest representable number such that \( 1.0 + \epsilon > 1.0 \).
!
!  It is assumed that \( f(a_x) \) and \( f(b_x) \) have opposite signs.
!
!# References
!  * R. P. Brent, "[An algorithm with guaranteed convergence for
!    finding a zero of a function](http://maths-people.anu.edu.au/~brent/pd/rpb005.pdf)",
!    The Computer Journal, Vol 14, No. 4., 1971.
!  * R. P. Brent, "[Algorithms for minimization without derivatives](http://maths-people.anu.edu.au/~brent/pub/pub011.html)",
!    Prentice-Hall, Inc., 1973.
!
!# See also
!  1. [zeroin.f](http://www.netlib.org/go/zeroin.f) from Netlib

    subroutine zeroin(f,ax,bx,tol,xzero,fzero,iflag,fax,fbx)

    use iso_fortran_env, only: error_unit

    implicit none

    procedure(func)              :: f       !! the function to find the root of
    real(wp),intent(in)          :: ax      !! left endpoint of initial interval
    real(wp),intent(in)          :: bx      !! right endpoint of initial interval
    real(wp),intent(in)          :: tol     !! desired length of the interval of uncertainty of the final result (>=0)
    real(wp),intent(out)         :: xzero   !! abscissa approximating a zero of `f` in the interval `ax`,`bx`
    real(wp),intent(out)         :: fzero   !! value of `f` at the root (`f(xzero)`)
    integer,intent(out)          :: iflag   !! status flag (`-1`=error, `0`=root found)
    real(wp),intent(in),optional :: fax     !! if `f(ax)` is already known, it can be input here
    real(wp),intent(in),optional :: fbx     !! if `f(ax)` is already known, it can be input here

    real(wp) :: a,b,c,d,e,fa,fb,fc,tol1,xm,p,q,r,s

    tol1 = eps+one

    a=ax
    b=bx

    if (present(fax)) then
        fa = fax
    else
        fa=f(a)
    end if
    if (present(fbx)) then
        fb = fbx
    else
        fb=f(b)
    end if

    !check trivial cases first:
    if (fa==zero) then

        iflag = 0
        xzero = a
        fzero = fa

    else if (fb==zero) then

        iflag = 0
        xzero = b
        fzero = fb

    else if (fa*(fb/abs(fb))<zero) then  ! check that f(ax) and f(bx) have different signs

        c=a
        fc=fa
        d=b-a
        e=d

        do

            if (abs(fc)<abs(fb)) then
                a=b
                b=c
                c=a
                fa=fb
                fb=fc
                fc=fa
            end if

            tol1 = two*eps*abs(b)+half*tol
            xm = half*(c-b)
            if ((abs(xm)<=tol1).or.(fb==zero)) exit

            ! see if a bisection is forced
            if ((abs(e)>=tol1).and.(abs(fa)>abs(fb))) then
                s=fb/fa
                if (a/=c) then
                    ! inverse quadratic interpolation
                    q=fa/fc
                    r=fb/fc
                    p=s*(two*xm*q*(q-r)-(b-a)*(r-one))
                    q=(q-one)*(r-one)*(s-one)
                else
                    ! linear interpolation
                    p=two*xm*s
                    q=one-s
                end if
                if (p<=zero) then
                    p=-p
                else
                    q=-q
                end if
                s=e
                e=d
                if (((two*p)>=(three*xm*q-abs(tol1*q))) .or. &
                    (p>=abs(half*s*q))) then
                    d=xm
                    e=d
                else
                    d=p/q
                end if
            else
                d=xm
                e=d
            end if

            a=b
            fa=fb
            if (abs(d)<=tol1) then
                if (xm<=zero) then
                    b=b-tol1
                else
                    b=b+tol1
                end if
            else
                b=b+d
            end if
            fb=f(b)
            if ((fb*(fc/abs(fc)))>zero) then
                c=a
                fc=fa
                d=b-a
                e=d
            end if

        end do

        iflag = 0
        xzero = b
        fzero = fb

    else

        iflag = -1
        write(error_unit,'(A)')&
            'Error in zeroin: f(ax) and f(bx) do not have different signs.'

    end if

    end subroutine zeroin
!*****************************************************************************************

!*****************************************************************************************
    end module root_module
!*****************************************************************************************


! { dg-do run }

module e_52_2_mod
contains
  subroutine init (v1, v2, N)
    integer :: i, N
    real :: v1(N), v2(N)
    do i = 1, N
      v1(i) = i + 2.0
      v2(i) = i - 3.0
    end do
  end subroutine

  subroutine init_again (v1, v2, N)
    integer :: i, N
    real :: v1(N), v2(N)
    do i = 1, N
      v1(i) = i - 3.0
      v2(i) = i + 2.0
    end do
  end subroutine

  subroutine check (p, N)
    integer :: i, N
    real, parameter :: EPS = 0.00001
    real :: diff, p(N)
    do i = 1, N
      diff = p(i) - (i * i + (i + 2.0) * (i - 3.0))
      if (diff > EPS .or. -diff > EPS) call abort
    end do
  end subroutine

  logical function maybe_init_again (v, N)
    real :: v(N)
    integer :: i, N
    do i = 1, N
      v(i) = i
    end do
    maybe_init_again = .true.
  end function

  subroutine vec_mult (p, v1, v2, N)
    real :: p(N), v1(N), v2(N)
    integer :: i, N
    logical :: changed
    call init (v1, v2, N)
    !$omp target data map(to: v1, v2) map(from: p)
      !$omp target
        !$omp parallel do
        do i = 1, N
          p(i) = v1(i) * v2(i)
        end do
      !$omp end target
      changed = maybe_init_again (v1, N)
      !$omp target update if(changed) to(v1(:N))
      changed = maybe_init_again (v2, N)
      !$omp target update if(changed) to(v2(:N))
      !$omp target
        !$omp parallel do
        do i = 1, N
          p(i) = p(i) + v1(i) * v2(i)
        end do
      !$omp end target
    !$omp end target data
    call check (p, N)
  end subroutine
end module

program e_52_2
  use e_52_2_mod, only : vec_mult
  integer :: n
  real, pointer :: p(:), v1(:), v2(:)
  n = 1000
  allocate (p(n), v1(n), v2(n))
  call vec_mult (p, v1, v2, n)
  deallocate (p, v1, v2)
end program


module cycle_tower_mod

    use constants
    use multifab_module

    implicit none

    type multi_array
        double precision, dimension(:,:,:), allocatable :: arr
    end type multi_array

    type cycle_tower
        integer                       :: dim = 3 ! # dimension of problem
        integer                       :: s1 = 2 ! # of smooths on each grid level, going down
        integer                       :: s2 = 2 ! # of smooths on each grid level, going up
        integer                       :: v_bot = 8 ! # of smooths at the bottom of the V-Cycle
        integer                       :: fmg_bot = 20 ! # of smooths at the bottom of the FMG-Cycle
        integer                       :: nlvl = 0 ! # of multigrid levels
        integer                       :: max_iter = 20 ! # of cycles before automatic program termination
        integer                       :: cycle_type = 1 ! V-Cycle
        integer                       :: interp_type = 1 ! Constant Interpolation
        integer                       :: rhs_type = 1 ! Sine wave
        integer                       :: coeffs_type = 1 ! Constant coefficients
        integer                       :: verbose = 1 ! How much to print
        integer         , allocatable :: n(:) ! Resolution at each grid level
        double precision              :: eps = 1E-10 ! Convergence threshold
        double precision, allocatable :: dx(:) ! Grid spacing, uniform in all directions, at each grid level
        type(multifab)  , allocatable :: uu(:) ! Solution at all grid levels, used for multigrid cycle
        type(multifab)  , allocatable :: ff(:) ! RHS at all grid levels, used for multigrid cycle
        type(multifab)  , allocatable :: bb(:,:) ! Beta coefficients, nodal in direction of second index
        type(multifab)  , allocatable :: res(:) ! Residual at all grid levels
        type(multifab)                :: sol ! Solution to our original problem
        type(multifab)                :: rhs ! RHS of our original problem
        type(multifab)                :: coeffs ! Cell-centered coefficients of our original problem
    end type cycle_tower

contains

   subroutine build_cycle_tower(ct,rhs,coeffs,la,dim,n_cells,dx,s1,s2,v_bot,fmg_bot,nlvl,max_iter,&
                                eps,cycle_type,interp_type,rhs_type,coeffs_type,verbose)

        use multifab_module
        use init_rhs_mod
        use init_coeffs_mod

        implicit none

        integer          , intent(in)    :: dim
        integer          , intent(in)    :: n_cells
        integer          , intent(in)    :: s1
        integer          , intent(in)    :: s2
        integer          , intent(in)    :: v_bot
        integer          , intent(in)    :: fmg_bot
        integer          , intent(in)    :: nlvl
        integer          , intent(in)    :: max_iter
        integer          , intent(in)    :: cycle_type
        integer          , intent(in)    :: interp_type
        integer          , intent(in)    :: rhs_type
        integer          , intent(in)    :: coeffs_type
        integer          , intent(in)    :: verbose
        double precision , intent(in)    :: eps
        double precision , intent(in)    :: dx
        type(multifab)   , intent(in)    :: rhs
        type(multifab)   , intent(in)    :: coeffs
        type(layout)     , intent(inout) :: la
        type(cycle_tower), intent(out)   :: ct

        integer                   :: lvl, d, i
        type(layout)              :: la_crse, la_temp

        integer :: lo(dim), hi(dim)
        double precision, pointer :: dp(:,:,:,:)

        ct%dim = dim
        ct%s1 = s1
        ct%s2 = s2
        ct%v_bot = v_bot
        ct%fmg_bot = fmg_bot
        ct%nlvl = nlvl
        ct%max_iter = max_iter
        ct%eps = eps
        ct%cycle_type = cycle_type
        ct%interp_type = interp_type
        ct%rhs_type = rhs_type
        ct%coeffs_type = coeffs_type
        ct%verbose = verbose

        allocate(ct%n(nlvl))
        allocate(ct%dx(nlvl))
        allocate(ct%uu(nlvl))
        allocate(ct%ff(nlvl))
        allocate(ct%res(nlvl))
        allocate(ct%bb(nlvl,dim))

        ct%rhs = rhs
        ct%coeffs = coeffs

        ! Build multifab for final solution, beginning with initial guess of zero
        call multifab_build(ct%sol,la,nc=1,ng=1)
        call setval(ct%sol,0.d0,all=.true.)

        ! Make a copy to be coarsened, so the actual layout isn't lost
        la_temp = la
        do lvl = nlvl,1,-1

            ct%n(lvl) = n_cells/2**(nlvl-lvl)
            ct%dx(lvl) = dx*2**(nlvl-lvl)

            ! Build multifabs at this grid level, to be used later in multigrid cycle
            call multifab_build(ct%uu(lvl),la_temp,nc=1,ng=1)
            call multifab_build(ct%ff(lvl),la_temp,nc=1,ng=0)
            call multifab_build(ct%res(lvl),la_temp,nc=1,ng=0)

            ! For each direction, build a beta-coefficient multifab that is nodal in only that direction
            do d = 1,dim
                call multifab_build_edge(ct%bb(lvl,d),la_temp,nc=1,ng=0,dir=d)
            end do

            ! Build coarsened version of layout, to be used for next multigrid level
            if (lvl > 1) then
                call layout_build_coarse(la_crse,la_temp,(/(2,lvl=1,ct%dim)/))
            end if

            la_temp = la_crse

        end do

        do d = 1,dim
            ! Nodalize coefficients in one direction and fill in appropriate multifab
            call fill_nodal_coeffs(ct%bb(nlvl,d),coeffs,d)
            do lvl = nlvl-1,1,-1
                ! Restrict nodalized coefficients at each multigrid level
                call restrict_coeffs(ct%bb(lvl,d),ct%bb(lvl+1,d),d)
            end do
        end do

        ! Set RHS of top multigrid level to be equal to RHS of original problem
        call copy(ct%ff(nlvl),ct%rhs)

        ! Set solution of top multigrid level to be zero
        call setval(ct%uu(nlvl),0.d0,all=.true.)

    end subroutine build_cycle_tower

    subroutine destroy_cycle_tower(ct)

        use multifab_module

        implicit none

        type(cycle_tower), intent(inout) :: ct

        integer :: lvl, d

        do lvl = 1,ct%nlvl

            call destroy(ct%uu(lvl))
            call destroy(ct%ff(lvl))
            call destroy(ct%res(lvl))

            do d = 1,ct%dim
                call destroy(ct%bb(lvl,d))
            end do

        end do

        call destroy(ct%sol)
        call destroy(ct%rhs)
        call destroy(ct%coeffs)

        deallocate(ct%dx)
        deallocate(ct%n)
        deallocate(ct%uu)
        deallocate(ct%ff)
        deallocate(ct%bb)
        deallocate(ct%res)

    end subroutine destroy_cycle_tower

    subroutine print_cycle_tower(ct,lvl,string)

        use traverse_mod

        implicit none

        integer          , intent(in) :: lvl
        character(len=*) , intent(in) :: string
        type(cycle_tower), intent(inout) :: ct

        logical :: p1,p2,p3,p4,p5
        integer :: n

        call residual(ct%res(lvl),ct%uu(lvl),ct%ff(lvl),ct%bb(lvl,:),ct%dx(lvl))

        if (ct%verbose <= 0) then
            p1 = .false.; p2 = .false.; p3 = .false.; p4 = .false.; p5 = .false.
        else if (ct%verbose == 1) then
            p1 = .false.; p2 = .false.; p3 = .false.; p4 = .false.; p5 = .false.
        else if (ct%verbose == 2) then
            p1 = .true.; p2 = .false.; p3 = .false.; p4 = .false.; p5 = .false.
        else if (ct%verbose == 3) then
            p1 = .true.; p2 = .true.; p3 = .false.; p4 = .false.; p5 = .false.
        else if (ct%verbose == 4) then
            p1 = .true.; p2 = .true.; p3 = .true.; p4 = .false.; p5 = .false.
        else if (ct%verbose == 5) then
            p1 = .true.; p2 = .true.; p3 = .true.; p4 = .true.; p5 = .false.
        else
            p1 = .true.; p2 = .true.; p3 = .true.; p4 = .true.; p5 = .true.
        end if

        if (p1 .or. p2 .or. p3 .or. p4) then
            write(*,'(a,a,$)') '   ',string
            if (p1) then
                write(*,'(a,i1,a,i3,a,es26.18)')'InfNorm residual(lvl=',lvl,' n=',ct%n(lvl),') = ',norm_inf(ct%res(lvl))
            end if
            if (p2) then
                write(*,'(a,i1,a)')'uu(lvl=',lvl,')'
                call print_multifab(ct%uu(lvl),'uu')
            end if
            if (p3) then
                write(*,'(a,i1,a)')'ff(lvl=',lvl,')'
                call print_multifab(ct%ff(lvl),'ff')
            end if
            if (p4) then
                write(*,'(a,i1,a)')'residual(lvl=',lvl,')'
                call print_multifab(ct%res(lvl),'res')
            end if
            if (p5) then
                write(*,'(a,i1,a)')'bbx(lvl=',lvl,')'
                call print_multifab(ct%bb(lvl,1),'bx')
                write(*,'(a,i1,a)')'bby(lvl=',lvl,')'
                call print_multifab(ct%bb(lvl,2),'by')
                if (ct%dim==3) then
                    write(*,'(a,i1,a)')'bbz(lvl=',lvl,')'
                    call print_multifab(ct%bb(lvl,3),'bz')
                end if
            end if
        end if

    end subroutine print_cycle_tower

    subroutine print_multifab(mf,string)

        use multifab_module

        implicit none

        type(multifab), intent(in) :: mf

        character(len=*)          :: string
        integer                   :: i, j, k, f
        integer                   :: lo(mf%dim),  hi(mf%dim)
        double precision, pointer :: dp(:,:,:,:)

        do f = 1,nfabs(mf)
            lo = lwb(get_pbox(mf,f))
            hi = upb(get_pbox(mf,f))
            write(*,'(a,a,i2,a)') string, ' fab ',f, ':'
            if (mf%dim==3) then
                dp => dataptr(mf,f)
                do k = lo(3),hi(3)
                    write(*,'(a,i2)') 'k =', k
                    do j = hi(2),lo(2),-1
                        print *, j, dp(:,j,k,1)
                    end do
                    write(*,'(a,$)') '           '
                    do i = lo(1),hi(1)
                        write(*,'(a,i0,a,$)') '            ', i, '            '
                    end do
                    print *, ''
                end do
            else if (mf%dim==2) then
                    dp => dataptr(mf,f)
                    do j = hi(2),lo(2),-1
                        write(*,'(i2,$)') j
                        do i = lo(1),hi(1)
                            write(*,'(es26.16,$)') dp(i,j,1,1)
                        end do
                        print *, ''
                    end do
                    write(*,'(a,$)') '  '
                    do i = lo(1),hi(1)
                        write(*,'(a,i0,a,$)') '             ', i, '            '
                    end do
                    print *, ''
            end if
        end do
        print *, ''

    end subroutine print_multifab

end module cycle_tower_mod


!#########################################################
!#########################################################
!#########################################################
!#########################################################
subroutine gravana(x,f,dx,ncell)
  use amr_parameters
  use poisson_parameters
  implicit none
  integer ::ncell                         ! Size of input arrays
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector,1:ndim)::f ! Gravitational acceleration
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine computes the acceleration using analytical models.
  ! x(i,1:ndim) are cell center position in [0,boxlen] (user units).
  ! f(i,1:ndim) is the gravitational acceleration in user units.
  !================================================================
  integer::idim,i
  real(dp)::gmass,emass,xmass,ymass,zmass,rr,rx,ry,rz
  real(dp):: cnfw,Mvirphu,rvir,pi
  pi=3.1415926_dp
  ! Constant vector
  if(gravity_type==1)then
     do idim=1,ndim
        do i=1,ncell
           f(i,idim)=gravity_params(idim)
        end do
     end do
  end if

  ! Point mass
  if(gravity_type==2)then
     gmass=gravity_params(1) ! GM
     emass=gravity_params(2) ! Softening length
     xmass=gravity_params(3) ! Point mass coordinates
     ymass=gravity_params(4)
     zmass=gravity_params(5)
     do i=1,ncell
        rx=0.0d0; ry=0.0d0; rz=0.0d0
        rx=x(i,1)-xmass
#if NDIM>1
        ry=x(i,2)-ymass
#endif
#if NDIM>2
        rz=x(i,3)-zmass
#endif
        rr=sqrt(rx**2+ry**2+rz**2+emass**2)
        f(i,1)=-gmass*rx/rr**3
#if NDIM>1
        f(i,2)=-gmass*ry/rr**3
#endif
#if NDIM>2
        f(i,3)=-gmass*rz/rr**3
#endif
     end do
  end if

  ! NFW
  if(gravity_type==3)then
     cnfw = 6./(Mvir/1.d14)**.2
     Mvirphu = Mvir*1.99d33
     rvir = (3./4./pi*Mvirphu/(overdensity*1.89d-29*0.65**2))**0.333
     xmass=0.5*boxlen
     ymass=0.5*boxlen
     zmass=0.5*boxlen
     do i=1,ncell
        rx=0.0d0; ry=0.0d0; rz=0.0d0
        rx=x(i,1)-xmass
#if NDIM>1
        ry=x(i,2)-ymass
#endif
#if NDIM>2
        rz=x(i,3)-zmass
#endif
        rr=sqrt(rx**2+ry**2+rz**2)
        gmass=6.672d-8*Mvirphu&
     &*(log(1.+cnfw*rr/rvir)-cnfw*rr/rvir/(1.+cnfw*rr/rvir))&
     &/(log(1.+cnfw)-cnfw/(1.+cnfw))
        f(i,1)=-gmass*rx/rr**3
#if NDIM>1
        f(i,2)=-gmass*ry/rr**3
#endif
#if NDIM>2
        f(i,3)=-gmass*rz/rr**3
#endif
     end do

  end if
end subroutine gravana


*DECK DSPENC
      DOUBLE PRECISION FUNCTION DSPENC (X)
C***BEGIN PROLOGUE  DSPENC
C***PURPOSE  Compute a form of Spence's integral due to K. Mitchell.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      DOUBLE PRECISION (SPENC-S, DSPENC-D)
C***KEYWORDS  FNLIB, SPECIAL FUNCTIONS, SPENCE'S INTEGRAL
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DSPENC(X) calculates the double precision Spence's integral
C for double precision argument X.  Spence's function defined by
C        integral from 0 to X of  -LOG(1-Y)/Y  DY.
C For ABS(X) .LE. 1, the uniformly convergent expansion
C        DSPENC = sum K=1,infinity  X**K / K**2     is valid.
C This is a form of Spence's integral due to K. Mitchell which differs
C from the definition in the NBS Handbook of Mathematical Functions.
C
C Spence's function can be used to evaluate much more general integral
C forms.  For example,
C        integral from 0 to Z of  LOG(A*X+B)/(C*X+D)  DX  =
C             LOG(ABS(B-A*D/C))*LOG(ABS(A*(C*X+D)/(A*D-B*C)))/C
C             - DSPENC (A*(C*Z+D)/(A*D-B*C)) / C.
C
C Ref -- K. Mitchell, Philosophical Magazine, 40, p.351 (1949).
C        Stegun and Abromowitz, AMS 55, p.1004.
C
C
C Series for SPEN       on the interval  0.          to  5.00000E-01
C                                        with weighted error   4.74E-32
C                                         log weighted error  31.32
C                               significant figures required  30.37
C                                    decimal places required  32.11
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS
C***REVISION HISTORY  (YYMMDD)
C   780201  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891115  Corrected third argument in reference to INITDS.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DSPENC
      DOUBLE PRECISION X, SPENCS(38), ALN, PI26, XBIG, D1MACH, DCSEVL
      LOGICAL FIRST
      SAVE SPENCS, PI26, NSPENC, XBIG, FIRST
      DATA SPENCS(  1) / +.1527365598 8924058729 4668491002 8 D+0      /
      DATA SPENCS(  2) / +.8169658058 0510144035 0183818527 1 D-1      /
      DATA SPENCS(  3) / +.5814157140 7787308729 7735064118 2 D-2      /
      DATA SPENCS(  4) / +.5371619814 5415275422 4788900531 9 D-3      /
      DATA SPENCS(  5) / +.5724704675 1858262332 1060305478 2 D-4      /
      DATA SPENCS(  6) / +.6674546121 6493363436 0783543858 9 D-5      /
      DATA SPENCS(  7) / +.8276467339 7156769815 8439168901 1 D-6      /
      DATA SPENCS(  8) / +.1073315673 0306789512 7000587335 4 D-6      /
      DATA SPENCS(  9) / +.1440077294 3032394023 3459033151 3 D-7      /
      DATA SPENCS( 10) / +.1984442029 9659063678 9887713960 8 D-8      /
      DATA SPENCS( 11) / +.2794005822 1636387202 0199482161 5 D-9      /
      DATA SPENCS( 12) / +.4003991310 8833118230 7258044590 8 D-10     /
      DATA SPENCS( 13) / +.5823462892 0446384713 6813583575 7 D-11     /
      DATA SPENCS( 14) / +.8576708692 6386892780 9791477122 4 D-12     /
      DATA SPENCS( 15) / +.1276862586 2801930459 8948303343 3 D-12     /
      DATA SPENCS( 16) / +.1918826209 0425170811 6238041606 2 D-13     /
      DATA SPENCS( 17) / +.2907319206 9771381777 9579971967 3 D-14     /
      DATA SPENCS( 18) / +.4437112685 2767804625 5747364174 5 D-15     /
      DATA SPENCS( 19) / +.6815727787 4145995278 6735913560 7 D-16     /
      DATA SPENCS( 20) / +.1053017386 0155744295 4701941664 4 D-16     /
      DATA SPENCS( 21) / +.1635389806 7523771000 5182173457 0 D-17     /
      DATA SPENCS( 22) / +.2551852874 9404639323 1090164258 1 D-18     /
      DATA SPENCS( 23) / +.3999020621 9993601127 7047037951 9 D-19     /
      DATA SPENCS( 24) / +.6291501645 2168118765 1414917119 9 D-20     /
      DATA SPENCS( 25) / +.9933827435 6756776438 0388775253 3 D-21     /
      DATA SPENCS( 26) / +.1573679570 7499648167 2176380586 6 D-21     /
      DATA SPENCS( 27) / +.2500595316 8494761293 6927095466 6 D-22     /
      DATA SPENCS( 28) / +.3984740918 3838111392 1066325333 3 D-23     /
      DATA SPENCS( 29) / +.6366473210 0828438926 9132629333 3 D-24     /
      DATA SPENCS( 30) / +.1019674287 2396783670 7706197333 3 D-24     /
      DATA SPENCS( 31) / +.1636881058 9135188411 1107413333 3 D-25     /
      DATA SPENCS( 32) / +.2633310439 4176501173 4527999999 9 D-26     /
      DATA SPENCS( 33) / +.4244811560 1239768172 2436266666 6 D-27     /
      DATA SPENCS( 34) / +.6855411983 6800529168 2474666666 6 D-28     /
      DATA SPENCS( 35) / +.1109122433 4380564340 1898666666 6 D-28     /
      DATA SPENCS( 36) / +.1797431304 9998914573 6533333333 3 D-29     /
      DATA SPENCS( 37) / +.2917505845 9760951732 9066666666 6 D-30     /
      DATA SPENCS( 38) / +.4742646808 9286710613 3333333333 3 D-31     /
      DATA PI26 / +1.644934066 8482264364 7241516664 6025189219 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DSPENC
      IF (FIRST) THEN
         NSPENC = INITDS (SPENCS, 38, 0.1*REAL(D1MACH(3)))
         XBIG = 1.0D0/D1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GT.2.0D0) GO TO 60
      IF (X.GT.1.0D0) GO TO 50
      IF (X.GT.0.5D0) GO TO 40
      IF (X.GE.0.0D0) GO TO 30
      IF (X.GT.(-1.D0)) GO TO 20
C
C HERE IF X .LE. -1.0
C
      ALN = LOG(1.0D0-X)
      DSPENC = -PI26 - 0.5D0*ALN*(2.0D0*LOG(-X)-ALN)
      IF (X.GT.(-XBIG)) DSPENC = DSPENC
     1  + (1.D0 + DCSEVL (4.D0/(1.D0-X)-1.D0, SPENCS, NSPENC))/(1.D0-X)
      RETURN
C
C -1.0 .LT. X .LT. 0.0
C
 20   DSPENC = -0.5D0*LOG(1.0D0-X)**2
     1  - X*(1.D0+DCSEVL(4.D0*X/(X-1.D0)-1.D0, SPENCS, NSPENC))/(X-1.D0)
      RETURN
C
C 0.0 .LE. X .LE. 0.5
C
 30   DSPENC = X*(1.D0 + DCSEVL (4.D0*X-1.D0, SPENCS, NSPENC))
      RETURN
C
C 0.5 .LT. X .LE. 1.0
C
 40   DSPENC = PI26
      IF (X.NE.1.D0) DSPENC = PI26 - LOG(X)*LOG(1.0D0-X)
     1  - (1.D0-X)*(1.D0+DCSEVL(4.D0*(1.D0-X)-1.D0, SPENCS, NSPENC))
      RETURN
C
C 1.0 .LT. X .LE. 2.0
C
 50   DSPENC = PI26 - 0.5D0*LOG(X)*LOG((X-1.D0)**2/X)
     1  + (X-1.D0)*(1.D0+DCSEVL(4.D0*(X-1.D0)/X-1.D0, SPENCS, NSPENC))/X
      RETURN
C
C X .GT. 2.0
C
 60   DSPENC = 2.0D0*PI26 - 0.5D0*LOG(X)**2
      IF (X.LT.XBIG) DSPENC = DSPENC
     1  - (1.D0 + DCSEVL (4.D0/X-1.D0, SPENCS, NSPENC))/X
      RETURN
C
      END


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

subroutine spike(y,w,spikecutoff,error)

!  Determine single spikes and set the corresponding weight to zero             !
!                                                                               !
!  Criteria for spike:                                                          !
!                                                                               !
!  |y(i)-ymed| > cutoff .AND.                                                   !
!                                                                               !
!  (y(i) < (y(i-1)+y(i+1))/2 - cutoff .OR. y(i) > max(y(i-1),y(i+1)) + cutoff)  !
!                                                                               !
!                                                                               !
!  where ymed is the median filtered value                                      !
!                                                                               !
!                                                                               !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 12/9-2006                                                            !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,j,k,m1,m2,winmax,nyear,nptperyear,npt,nenvi,printflag,debugflag
integer :: win(3),error
double precision :: y(npt),w(npt),yext(npt+2*nptperyear/5),wext(npt+2*nptperyear/5)
double precision :: ymean,ystd,ymed,spikecutoff,dist,ynzw(2*nptperyear/5+1),wfact

common /parameters/ nyear,nptperyear,npt,nenvi,printflag,debugflag,wfact,win

ymean = sum(y)/dble(npt)
ystd = sqrt(dot_product(y-ymean,y-ymean)/dble(npt-1))
dist = spikecutoff*ystd

winmax = nptperyear/7  ! 5/7/10????????????

wext = (/ w(npt-winmax+1:npt),w,w(1:winmax) /)
yext = (/ y(npt-winmax+1:npt),y,y(1:winmax) /)

!---- Find single spikes by comparing with median filtered values and with -----
!     closest neighbors. If spike set corresponding weight to zero

do i = 1+winmax,npt+winmax
  m1 = i - winmax
  m2 = i + winmax

  k = 0
  do j = m1,m2
    if (wext(j) > 0.d0) then
	  k = k + 1
      ynzw(k) = yext(j)
    end if
  end do
  if (k > 0) then
!    write(*,*) 'error in spike'
!	error = 1
!	return
!  end if
    call median(ynzw(1:k),k,ymed)
    if ( (abs(y(i-winmax) - ymed) >= dist) .and. &
      ( (y(i-winmax) < (yext(i-1)+yext(i+1))/2.d0 - dist) .or. &
        (y(i-winmax) > max( yext(i-1),yext(i+1) ) + dist) ) ) then
      w(i-winmax) = 0.d0
    end if
  end if
end do

end subroutine spike


program test
  use supercell, only: find_optimal_cell

  implicit none
  real*8,  dimension(3, 3) :: matrix
  real*8,  dimension(3, 3) :: metric
  integer, dimension(3, 3) :: smatrix

  ! define some matrix
  ! matrix(1,1:3) =  (/ 0.d0, 2.d0, 2.d0 /)
  ! matrix(2,1:3) =  (/ 2.d0, 0.d0, 2.d0 /)
  ! matrix(3,1:3) =  (/ 2.d0, 2.d0, 0.d0 /)

  ! GaO:
  matrix(1,1:3) =  (/  6.22768603, -1.54124518,  0.        /)
  matrix(2,1:3) =  (/  6.22768603,  1.54124518,  0.        /)
  matrix(3,1:3) =  (/ -1.39028711,  0.        ,  5.7080621 /)

  ! Metric: cubic cell
  metric(1,1:3) =  (/ 1.d0, 0.d0, 0.d0 /)
  metric(2,1:3) =  (/ 0.d0, 1.d0, 0.d0 /)
  metric(3,1:3) =  (/ 0.d0, 0.d0, 1.d0 /)

  smatrix = find_optimal_cell(transpose(matrix), metric, 22.2d0, verbose=.true., &
    lower_limit=-3, upper_limit=3)
  ! smatrix = find_optimal_cell(matrix, metric, 30, verbose=.true.)
  write (*,"(A,/,3(F7.2))") 'Initial Matrix:', matrix
  write (*,"(A,/,3(I7))") 'Supercell mat.:', smatrix
  write (*,"(A,/,3(F7.2))") 'Supercell lat.:', matmul(transpose(matrix), smatrix)

end program


************************************************************************
* isr.f
*
* Last update: Jul 06, 2007
*
* This file contains the implementation of the structure function
* ffISR for Initial State Radiation (ISR).
************************************************************************

      real*8 function ffISR(xx,Qscale)

      implicit real*8 (a-h,o-z)

* implementation of electron/positron structure function:
c QED Leading Log ISR structure function O(alpha_EM**3)
c Based on results by the "WW cross sections and distributions" working
c group, CERN Workshop "Physics at LEP2" (1994/1995)  [hep-ph/9602351]

      parameter(nterm=10)       ! Bernoulli
      external rli2             ! dilogarithm function
      parameter(rme=0.51099906d-3,alpha_me=1.d0/137.0359895d0,
     &     ge=0.5772156649d0,pi=3.141592653589793238462643d0)

      s=QScale**2
      rl=dlog(s/rme/rme)
      betah=alpha_me*(rl-1.d0)/pi
      gamma=exp(gammln(1.d0+betah))
      rlim=exp(betah*(0.75d0-ge))*betah/gamma

* Implementation of the structure function.
c Note: the structure function is multiplied by a factor
c (1.d0/betah)*(1.d0-xx)**(1.d0-betah) which represents the jacobian
c associated to the mapping: x_vegas = (1.d0 - x_map)**betah

      CALL Bernoulli(nterm)
      if(xx.eq.1.d0)then
        ffISR = rlim
      else
        ffISR = rlim + (1.d0-xx)**(1.d0-betah)*(
c O(betah) contribution
     &       -betah*(1.d0+xx)/2.d0
c O(betah**2) contribution
     &       +(betah**2/8.d0)*(-4.d0*(1.d0+xx)*log(1.d0-xx)+3.d0
     &       *(1.d0+xx)*log(xx)-4.d0*log(xx)/(1.
     &       d0-xx)-5.d0-xx)
c O(betah**3) contribution
     &       -(betah**3/48.d0)*((1+xx)*(6.d0*rli2(xx,nterm)+
     &       12.d0*log(1-xx)*log(1-xx)-3.d0*pi**2)+(1.d0/(1.d0-xx))
     &       *(1.5d0*(1.d0+8.d0*xx+3.d0*xx**2)*log(xx)+
     &       6.d0*(xx+5)*(1-xx)*log(1-xx)+
     &       12.d0*(1+xx**2)*log(xx)*log(1-xx)-
     &       0.5d0*(1.d0+7.d0*xx**2)*log(xx)*log(xx)+
     &       0.25d0*(39.d0-24.d0*xx-15.d0*xx**2)))
     &       )
      endif

      ffISR=ffISR/betah

      return
      end

      subroutine map_ISR(x1,x2,Q2scale,xx1,xx2)

      implicit real*8 (a-h,o-z)

      parameter(rme=0.51099906d-3,alpha_me=1.d0/137.0359895d0,
     &     pi=3.141592653589793238462643d0)

* implementation of mapping
      rl=dlog(Q2scale/rme/rme)
      betah=alpha_me*(rl-1.d0)/pi

      xx1=1.d0-x1**(1.d0/betah)
      xx2=1.d0-x2**(1.d0/betah)

      return
      end

      double precision FUNCTION gammln(xx)

      IMPLICIT NONE
      REAL*8 xx
      INTEGER j
      double precision ser,stp,tmp,xa,y,cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
     *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     *-.5395239384953d-5,2.5066282746310005d0/
      xa=xx
      y=xa
      tmp=xa+5.5d0
      tmp=(xa+0.5d0)*log(tmp)-tmp
      ser=1.000000000190015d0
      DO 11 j=1,6
        y=y+1.d0
        ser=ser+cof(j)/y
   11 CONTINUE
      gammln=tmp+log(stp*ser/xa)
      RETURN
      END
C  (C) Copr. 1986-92 Numerical Recipes Software #>,1')5c).


*###[ ffxa0:
	subroutine ffxa0(ca0,xm,ier)
***#[*comment:***********************************************************
*									*
*	calculates the one-point function (see 't Hooft and		*
*	Veltman) for real mass						*
*									*
*	Input:	xm	(real) mass2,					*
*									*
*	Output:	ca0	(complex) A0, the one-point function,		*
*		ier	0 (ok)						*
*									*
*	Calls:	log.							*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	DOUBLE COMPLEX ca0
	DOUBLE PRECISION xm
*
*	local variables
*
	DOUBLE PRECISION xmu,xlogm
*
*	common blocks etc
*
	include 'ff.h'
*  #] declarations:
*  #[ "calculations":
	if ( mudim2 .ne. 0 ) then
	    xmu = xm/mudim2
	else
	    xmu = xm
	endif
	if ( xmu .gt. xalogm ) then
	    xlogm = log(xmu)
	else
	    xlogm = 0
	    if ( xmu .ne. 0 ) call fferr(2,ier)
	endif
	ca0 = -(xm*(xlogm - 1 - divergence))
*  #] "calculations":
*###] ffxa0:
	end


c---+----1----+----2----+----3----+----4
      program main
      double precision price_pay,price_org,discout,tax
      discount=0.1d0
      tax=0.05d0
      price_org=980.0d0
      price_pay=price_org*(1.0d0-discount)*(1.0d0+tax)
      write(6,*) 'You should pay',price_pay,'Yen'
      stop
      end