      SUBROUTINE TB05AD( BALEIG, INITA, N, M, P, FREQ, A, LDA, B, LDB,
     $                   C, LDC, RCOND, G, LDG, EVRE, EVIM, HINVB,
     $                   LDHINV, IWORK, DWORK, LDWORK, ZWORK, LZWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find the complex frequency response matrix (transfer matrix)
C     G(freq) of the state-space representation (A,B,C) given by
C                                   -1
C        G(freq) = C * ((freq*I - A)  ) * B
C
C     where A, B and C are real N-by-N, N-by-M and P-by-N matrices
C     respectively and freq is a complex scalar.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     BALEIG  CHARACTER*1
C             Determines whether the user wishes to balance matrix A
C             and/or compute its eigenvalues and/or estimate the
C             condition number of the problem as follows:
C             = 'N':  The matrix A should not be balanced and neither
C                     the eigenvalues of A nor the condition number
C                     estimate of the problem are to be calculated;
C             = 'C':  The matrix A should not be balanced and only an
C                     estimate of the condition number of the problem
C                     is to be calculated;
C             = 'B' or 'E' and INITA = 'G':  The matrix A is to be
C                     balanced and its eigenvalues calculated;
C             = 'A' and INITA = 'G':  The matrix A is to be balanced,
C                     and its eigenvalues and an estimate of the
C                     condition number of the problem are to be
C                     calculated.
C
C     INITA   CHARACTER*1
C             Specifies whether or not the matrix A is already in upper
C             Hessenberg form as follows:
C             = 'G':  The matrix A is a general matrix;
C             = 'H':  The matrix A is in upper Hessenberg form and
C                     neither balancing nor the eigenvalues of A are
C                     required.
C             INITA must be set to 'G' for the first call to the
C             routine, unless the matrix A is already in upper
C             Hessenberg form and neither balancing nor the eigenvalues
C             of A are required. Thereafter, it must be set to 'H' for
C             all subsequent calls.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of states, i.e. the order of the state
C             transition matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of inputs, i.e. the number of columns in the
C             matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of outputs, i.e. the number of rows in the
C             matrix C.  P >= 0.
C
C     FREQ    (input) COMPLEX*16
C             The frequency freq at which the frequency response matrix
C             (transfer matrix) is to be evaluated.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state transition matrix A.
C             If INITA = 'G', then, on exit, the leading N-by-N part of
C             this array contains an upper Hessenberg matrix similar to
C             (via an orthogonal matrix consisting of a sequence of
C             Householder transformations) the original state transition
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input/state matrix B.
C             If INITA = 'G', then, on exit, the leading N-by-M part of
C             this array contains the product of the transpose of the
C             orthogonal transformation matrix used to reduce A to upper
C             Hessenberg form and the original input/state matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             If INITA = 'G', then, on exit, the leading P-by-N part of
C             this array contains the product of the original output/
C             state matrix C and the orthogonal transformation matrix
C             used to reduce A to upper Hessenberg form.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     RCOND   (output) DOUBLE PRECISION
C             If BALEIG = 'C' or BALEIG = 'A', then RCOND contains an
C             estimate of the reciprocal of the condition number of
C             matrix H with respect to inversion (see METHOD).
C
C     G       (output) COMPLEX*16 array, dimension (LDG,M)
C             The leading P-by-M part of this array contains the
C             frequency response matrix G(freq).
C
C     LDG     INTEGER
C             The leading dimension of array G.  LDG >= MAX(1,P).
C
C     EVRE,   (output) DOUBLE PRECISION arrays, dimension (N)
C     EVIM    If INITA = 'G' and BALEIG = 'B' or 'E' or BALEIG = 'A',
C             then these arrays contain the real and imaginary parts,
C             respectively, of the eigenvalues of the matrix A.
C             Otherwise, these arrays are not referenced.
C
C     HINVB   (output) COMPLEX*16 array, dimension (LDHINV,M)
C             The leading N-by-M part of this array contains the
C                      -1
C             product H  B.
C
C     LDHINV  INTEGER
C             The leading dimension of array HINVB.  LDHINV >= MAX(1,N).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
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, N - 1 + MAX(N,M,P)),
C                       if INITA = 'G' and BALEIG = 'N', or 'B', or 'E';
C             LDWORK >= MAX(1, N + MAX(N,M-1,P-1)),
C                       if INITA = 'G' and BALEIG = 'C', or 'A';
C             LDWORK >= MAX(1, 2*N),
C                       if INITA = 'H' and BALEIG = 'C', or 'A';
C             LDWORK >= 1, otherwise.
C             For optimum performance when INITA = 'G' LDWORK should be
C             larger.
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C
C     LZWORK  INTEGER
C             The length of the array ZWORK.
C             LZWORK >= MAX(1,N*N+2*N), if BALEIG = 'C', or 'A';
C             LZWORK >= MAX(1,N*N),     otherwise.
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 more than 30*N iterations are required to
C                   isolate all the eigenvalues of the matrix A; the
C                   computations are continued;
C             = 2:  if either FREQ is too near to an eigenvalue of the
C                   matrix A, or RCOND is less than EPS, where EPS is
C                   the machine  precision (see LAPACK Library routine
C                   DLAMCH).
C
C     METHOD
C
C     The matrix A is first balanced (if BALEIG = 'B' or 'E', or
C     BALEIG = 'A') and then reduced to upper Hessenberg form; the same
C     transformations are applied to the matrix B and the matrix C.
C     The complex Hessenberg matrix  H = (freq*I - A) is then used
C                       -1
C     to solve for C * H  * B.
C
C     Depending on the input values of parameters BALEIG and INITA,
C     the eigenvalues of matrix A and the condition number of
C     matrix H with respect to inversion are also calculated.
C
C     REFERENCES
C
C     [1] Laub, A.J.
C         Efficient Calculation of Frequency Response Matrices from
C         State-Space Models.
C         ACM TOMS, 12, pp. 26-33, 1986.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TB01FD by A.J.Laub, University of
C     Southern California, Los Angeles, CA 90089, United States of
C     America, June 1982.
C
C     REVISIONS
C
C     V. Sima, February 22, 1998 (changed the name of TB01RD).
C     V. Sima, February 12, 1999, August 7, 2003.
C     A. Markovski, Technical University of Sofia, September 30, 2003.
C     V. Sima, October 1, 2003.
C
C     KEYWORDS
C
C     Frequency response, Hessenberg form, matrix algebra, input output
C     description, multivariable system, orthogonal transformation,
C     similarity transformation, state-space representation, transfer
C     matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
      COMPLEX*16        CZERO
      PARAMETER         ( CZERO = ( 0.0D0, 0.0D0 ) )
C     .. Scalar Arguments ..
      CHARACTER         BALEIG, INITA
      INTEGER           INFO, LDA, LDB, LDC, LDG, LDHINV, LDWORK,
     $                  LZWORK, M, N, P
      DOUBLE PRECISION  RCOND
      COMPLEX*16        FREQ
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), EVIM(*),
     $                  EVRE(*)
      COMPLEX*16        ZWORK(*), G(LDG,*), HINVB(LDHINV,*)
C     .. Local Scalars ..
      CHARACTER         BALANC
      LOGICAL           LBALBA, LBALEA, LBALEB, LBALEC, LINITA
      INTEGER           I, IGH, IJ, ITAU, J, JJ, JP, JWORK, K, LOW,
     $                  WRKOPT
      DOUBLE PRECISION  HNORM, T
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DASUM, DLAMCH
      EXTERNAL          DASUM, DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEBAL, DGEHRD, DHSEQR, DORMHR, DSCAL, DSWAP,
     $                  MB02RZ, MB02SZ, MB02TZ, XERBLA, ZLASET
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, DCMPLX, INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LBALEC = LSAME( BALEIG, 'C' )
      LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' )
      LBALEA = LSAME( BALEIG, 'A' )
      LBALBA = LBALEB.OR.LBALEA
      LINITA = LSAME( INITA,  'G' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LBALEC .AND. .NOT.LBALBA .AND.
     $    .NOT.LSAME( BALEIG, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LINITA .AND. .NOT.LSAME( INITA, 'H' ) ) 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, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDG.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDHINV.LT.MAX( 1, N ) ) THEN
         INFO = -19
      ELSE IF( ( LINITA .AND. .NOT.LBALEC .AND. .NOT.LBALEA .AND.
     $           LDWORK.LT.N - 1 + MAX( N, M, P ) ) .OR.
     $         ( LINITA .AND. ( LBALEC .OR. LBALEA ) .AND.
     $           LDWORK.LT.N + MAX( N, M-1, P-1 ) ) .OR.
     $         ( .NOT.LINITA .AND. ( LBALEC .OR. LBALEA ) .AND.
     $           LDWORK.LT.2*N ) .OR. ( LDWORK.LT.1 ) ) THEN
         INFO = -22
      ELSE IF( ( ( LBALEC .OR. LBALEA ) .AND. LZWORK.LT.N*( N + 2 ) )
     $      .OR. ( LZWORK.LT.MAX( 1, N*N ) ) ) THEN
         INFO = -24
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return
C
         CALL XERBLA( 'TB05AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         IF ( MIN( M, P ).GT.0 )
     $      CALL ZLASET( 'Full', P, M, CZERO, CZERO, G, LDG )
         RCOND = ONE
         DWORK(1) = ONE
         RETURN
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      WRKOPT = 1
C
      IF ( LINITA ) THEN
         BALANC = 'N'
         IF ( LBALBA ) BALANC = 'B'
C
C        Workspace: need N.
C
         CALL DGEBAL( BALANC, N, A, LDA, LOW, IGH, DWORK, INFO )
         IF ( LBALBA ) THEN
C
C           Adjust B and C matrices based on information in the
C           vector DWORK which describes the balancing of A and is
C           defined in the subroutine DGEBAL.
C
            DO 10 J = 1, N
               JJ = J
               IF ( JJ.LT.LOW .OR. JJ.GT.IGH ) THEN
                  IF ( JJ.LT.LOW ) JJ = LOW - JJ
                  JP = DWORK(JJ)
                  IF ( JP.NE.JJ ) THEN
C
C                    Permute rows of B.
C
                     IF ( M.GT.0 )
     $                  CALL DSWAP( M, B(JJ,1), LDB, B(JP,1), LDB )
C
C                    Permute columns of C.
C
                     IF ( P.GT.0 )
     $                  CALL DSWAP( P, C(1,JJ), 1, C(1,JP), 1 )
                  END IF
               END IF
   10       CONTINUE
C
            IF ( IGH.NE.LOW ) THEN
C
               DO 20 J = LOW, IGH
                  T = DWORK(J)
C
C                 Scale rows of permuted B.
C
                  IF ( M.GT.0 )
     $               CALL DSCAL( M, ONE/T, B(J,1), LDB )
C
C                 Scale columns of permuted C.
C
                  IF ( P.GT.0 )
     $               CALL DSCAL( P, T, C(1,J), 1 )
   20          CONTINUE
C
            END IF
         END IF
C
C        Reduce A to Hessenberg form by orthogonal similarities and
C        accumulate the orthogonal transformations into B and C.
C        Workspace: need 2*N - 1;  prefer N - 1 + N*NB.
C
         ITAU = 1
         JWORK = ITAU + N - 1
         CALL DGEHRD( N, LOW, IGH, A, LDA, DWORK(ITAU), DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Workspace: need N - 1 + M;  prefer N - 1 + M*NB.
C
         CALL DORMHR( 'Left', 'Transpose', N, M, LOW, IGH, A, LDA,
     $                DWORK(ITAU), B, LDB, DWORK(JWORK), LDWORK-JWORK+1,
     $                INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Workspace: need N - 1 + P;  prefer N - 1 + P*NB.
C
         CALL DORMHR( 'Right', 'No transpose', P, N, LOW, IGH, A, LDA,
     $                DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1,
     $                INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
         IF ( LBALBA ) THEN
C
C           Temporarily store Hessenberg form of A in array ZWORK.
C
            IJ = 0
            DO 40 J = 1, N
C
               DO 30 I = 1, N
                  IJ = IJ + 1
                  ZWORK(IJ) = DCMPLX( A(I,J), ZERO )
   30          CONTINUE
C
   40       CONTINUE
C
C           Compute the eigenvalues of A if that option is requested.
C           Workspace: need N.
C
            CALL DHSEQR( 'Eigenvalues', 'No Schur', N, LOW, IGH, A, LDA,
     $                   EVRE, EVIM, DWORK, 1, DWORK, LDWORK, INFO )
C
C           Restore upper Hessenberg form of A.
C
            IJ = 0
            DO 60 J = 1, N
C
               DO 50 I = 1, N
                  IJ = IJ + 1
                  A(I,J) = DBLE( ZWORK(IJ) )
   50          CONTINUE
C
   60       CONTINUE
C
            IF ( INFO.GT.0 ) THEN
C
C              DHSEQR could not evaluate the eigenvalues of A.
C
               INFO = 1
            END IF
         END IF
      END IF
C
C     Update  H := (FREQ * I) - A   with appropriate value of FREQ.
C
      IJ = 0
      JJ = 1
      DO 80 J = 1, N
C
         DO 70 I = 1, N
            IJ = IJ + 1
            ZWORK(IJ) = -DCMPLX( A(I,J), ZERO )
   70    CONTINUE
C
         ZWORK(JJ) = FREQ + ZWORK(JJ)
         JJ = JJ + N + 1
   80 CONTINUE
C
      IF ( LBALEC .OR. LBALEA ) THEN
C
C        Efficiently compute the 1-norm of the matrix for condition
C        estimation.
C
         HNORM = ZERO
         JJ = 1
C
         DO 90 J = 1, N
            T = ABS( ZWORK(JJ) ) + DASUM( J-1, A(1,J), 1 )
            IF ( J.LT.N ) T = T + ABS( A(J+1,J) )
            HNORM = MAX( HNORM, T )
            JJ = JJ + N + 1
   90    CONTINUE
C
      END IF
C
C     Factor the complex Hessenberg matrix.
C
      CALL MB02SZ( N, ZWORK, N, IWORK, INFO )
      IF ( INFO.NE.0 ) INFO = 2
C
      IF ( LBALEC .OR. LBALEA ) THEN
C
C        Estimate the condition of the matrix.
C
C        Workspace: need 2*N.
C
         CALL MB02TZ( '1-norm', N, HNORM, ZWORK, N, IWORK, RCOND, DWORK,
     $                ZWORK(N*N+1), INFO )
         WRKOPT = MAX( WRKOPT, 2*N )
         IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) INFO = 2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return: Linear system is numerically or exactly singular.
C
         RETURN
      END IF
C
C     Compute  (H-INVERSE)*B.
C
      DO 110 J = 1, M
C
         DO 100 I = 1, N
            HINVB(I,J) = DCMPLX( B(I,J), ZERO )
  100    CONTINUE
C
  110 CONTINUE
C
      CALL MB02RZ( 'No transpose', N, M, ZWORK, N, IWORK, HINVB, LDHINV,
     $             INFO )
C
C     Compute  C*(H-INVERSE)*B.
C
      DO 150 J = 1, M
C
         DO 120 I = 1, P
            G(I,J) = CZERO
  120    CONTINUE
C
         DO 140 K = 1, N
C
            DO 130 I = 1, P
               G(I,J) = G(I,J) + DCMPLX( C(I,K), ZERO )*HINVB(K,J)
  130       CONTINUE
C
  140    CONTINUE
C
  150 CONTINUE
C
C     G now contains the desired frequency response matrix.
C     Set the optimal workspace.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TB05AD ***
      END


c     # ------------------------------------------------------------
c     # Streamfunction, velocity components and derivatives
c     #
c     # ------------------------------------------------------------
      double precision function torus_psi(x,y)
      implicit none

      double precision x, y

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta
      common /torus_comm/ alpha, beta

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      double precision psi

      if (beta .ne. 0) then
          write(6,'(A,A)') 'psi (psi.f) : Streamfunction only works ',
     &         'for beta == 0'
          stop 'error'
      endif

      psi = pi2*revs_per_s*alpha*(pi2*y + alpha*sin(pi2*y))

      torus_psi = psi

      end

c     # ------------------------------------------------------------
c     # Edge : u = \nabla cross \Psi - curl \Psi
c     # NOTE : This depends on computational coordinates, not
c     # physical coordinates.
c     # ------------------------------------------------------------
      subroutine torus_edge_velocity(x1,y1,x2,y2,ds,vn)
      implicit none

      double precision x1,y1,x2,y2, ds, vn, torus_psi

      vn = (torus_psi(x1,y1) - torus_psi(x2,y2))/ds

      end


C  (C) Copr. 1986-92 Numerical Recipes Software.

       real*8 function bessi0(x)
       real*8 x
c Returns the modified bessel function I0(x) for any real x
       real*8 ax
       double precision p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,
     &  q8,q9,y
       save p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
       data p1,p2,p3,p4,p5,p6,p7/1.0d0,3.5156229d0,3.0899424d0,
     &   1.2067492d0,0.2659732d0,0.360768d-1,0.45813d-2/
       data q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,0.1328592d-1,
     &  0.225319d-2,-0.157565d-2,0.916281d-2,-0.2057706d-1,
     &  0.2635537d-1,-0.1647633d-1,0.392377d-2/
       if(abs(x).lt.3.75d0)then
         y=(x/3.75d0)**2
         bessi0=p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7)))))
       else
        ax=abs(x)
        y=3.75d0/ax
        bessi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4
     &     +y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
       endif
       return
       end

       real*8 FUNCTION bessk0(x)

       double precision x
C USES bessi0
C Returns the modified Bessel function K0(x) for positive real x.
       REAL*8 bessi0
       DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,
     * q2,q3,q4,q5,q6,q7,y

       SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7

       DATA p1,p2,p3,p4,p5,p6,p7/-.57721566d0,.42278420d0,.23069756d0,
     * .3488590d-1,.262698d-2,.10750d-3,.74d-5/

       DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,-.7832358d-1,.2189568d-1,
     * -.1062446d-1,.587872d-2,-.251540d-2,.53208d-3/

       if (x.le.2.0d0) then
        y=x*x/4.0d0
        bessk0=(-log(x/2.0d0)*bessi0(x))+(p1+y*(p2+y*(p3+
     * y*(p4+y*(p5+y*(p6+y*p7))))))
       else
        y=(2.0d0/x)
       bessk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+
     * y*(q4+y*(q5+y*(q6+y*q7))))))

       endif
       return
       END

       real*8 FUNCTION bessi1(x)

       double precision x

       REAL*8 ax
       DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,
     * q8,q9,y

       SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
       DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,
     * 0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
       DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,-0.3988024d-1,
     * -0.362018d-2,0.163801d-2,-0.1031555d-1,0.2282967d-1,
     * -0.2895312d-1,0.1787654d-1,-0.420059d-2/
       if (abs(x).lt.3.75d0) then
        y=(x/3.75d0)**2
        bessi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
       else
        ax=abs(x)
        y=3.75d0/ax
        bessi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+
     * y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
       if(x.lt.0.0d0)bessi1=-bessi1
       endif
       return
       END

       real*8 function bessk1(x)
       real*8 x
c     uses bessi1
c     returns the modified Bessel function Ki(x) for positive real x
       real*8 bessi1
       double precision p1,p2,p3,p4,p5,p6,p7,q1,
     &  q2,q3,q4,q5,q6,q7,y
       save p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
       data p1,p2,p3,p4,p5,p6,p7/1.0d0,0.15443144d0,-0.67278579d0,
     &  -0.18156897d0,-0.1919402d-1,-0.110404d-2,-0.4686d-4/
       data q1,q2,q3,q4,q5,q6,q7/1.25331414d0,0.23498618d0,
     &  -0.3655620d-1,
     &  0.1504268d-1,-0.780353d-2,0.325614d-2,-0.68245d-3/
       if (x.le.2.0d0) then
          y=x*x/4.0d0
          bessk1=(log(x/2.0d0)*bessi1(x))+(1.0d0/x)*(p1+y*(p2+
     &      y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
       else
          y=2.0d0/x
          bessk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+
     &      y*(q6+y*q7))))))
       endif
       return
       end

       real*8 FUNCTION bessk(n,x)
       INTEGER n
       REAL*8 x
C      USES bessk0,bessk1
c      Returns the modified Bessel function Kn(x) for positive x and n >= 2.
       INTEGER j
       REAL*8 bk,bkm,bkp,tox,bessk0,bessk1

       if (n.lt.2.0d0) then
        write(6,*) 'n < 2 in bessel.f'
       end if
       tox=2.0d0/x

       bkm=bessk0(x)
       bk=bessk1(x)

       do j=1,n-1
        bkp=bkm+j*tox*bk
        bkm=bk
        bk=bkp
       end do
       bessk=bk
       return
       END

C  (C) Copr. 1986-92 Numerical Recipes Software.


! { dg-do run }
!
! Test the fix for PR37749 in which the expression in line 13 would cause an ICE
! because the upper value of the loop range was not set.
!
! Contributed by Jakub Jelinek <jakub@gcc.gnu.org>
!
subroutine subr (m, n, a, b, c, d, p)
  implicit none
  integer m, n
  real a(m,n), b(m,n), c(n,n), d(m,n)
  integer p(n)
  d = a(:,p) - matmul(b, c)
end subroutine

  implicit none
  integer i
  real a(3,2), b(3,2), c(2,2), d(3,2)
  integer p(2)
  a = reshape ((/(i, i = 1, 6)/), (/3, 2/))
  b = 1
  c = 2
  p = 2
  call subr (3, 2, a, b, c, d, p)
  if (any (d .ne. reshape ((/(mod (i + 2, 3), i = 1, 6)/), (/3, 2/)))) call abort
end


	SUBROUTINE spolint(xa,ya,x,y,dy)
	use mo_kind
        use mo_nrutil, ONLY : assert_eq,iminloc,nrerror
	IMPLICIT NONE
	REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya
	REAL(SP), INTENT(IN) :: x
	REAL(SP), INTENT(OUT) :: y,dy
	INTEGER(I4) :: m,n,ns
	REAL(SP), DIMENSION(size(xa)) :: c,d,den,ho
	n=assert_eq(size(xa),size(ya),'polint')
	c=ya
	d=ya
	ho=xa-x
	ns=iminloc(abs(x-xa))
	y=ya(ns)
	ns=ns-1
	do m=1,n-1
		den(1:n-m)=ho(1:n-m)-ho(1+m:n)
		if (any(den(1:n-m) == 0.0)) &
			call nrerror('polint: calculation failure')
		den(1:n-m)=(c(2:n-m+1)-d(1:n-m))/den(1:n-m)
		d(1:n-m)=ho(1+m:n)*den(1:n-m)
		c(1:n-m)=ho(1:n-m)*den(1:n-m)
		if (2*ns < n-m) then
			dy=c(ns+1)
		else
			dy=d(ns)
			ns=ns-1
		end if
		y=y+dy
	end do
	END SUBROUTINE spolint

	SUBROUTINE dpolint(xa,ya,x,y,dy)
	use mo_kind
        use mo_nrutil, ONLY : assert_eq,iminloc,nrerror
	IMPLICIT NONE
	REAL(DP), DIMENSION(:), INTENT(IN) :: xa,ya
	REAL(DP), INTENT(IN) :: x
	REAL(DP), INTENT(OUT) :: y,dy
	INTEGER(I4) :: m,n,ns
	REAL(DP), DIMENSION(size(xa)) :: c,d,den,ho
	n=assert_eq(size(xa),size(ya),'polint')
	c=ya
	d=ya
	ho=xa-x
	ns=iminloc(abs(x-xa))
	y=ya(ns)
	ns=ns-1
	do m=1,n-1
		den(1:n-m)=ho(1:n-m)-ho(1+m:n)
		if (any(den(1:n-m) == 0.0)) &
			call nrerror('polint: calculation failure')
		den(1:n-m)=(c(2:n-m+1)-d(1:n-m))/den(1:n-m)
		d(1:n-m)=ho(1+m:n)*den(1:n-m)
		c(1:n-m)=ho(1:n-m)*den(1:n-m)
		if (2*ns < n-m) then
			dy=c(ns+1)
		else
			dy=d(ns)
			ns=ns-1
		end if
		y=y+dy
	end do
	END SUBROUTINE dpolint


c { dg-do run }
      program complex_1
      complex      z0, z1, z2

      z0 = cmplx(0.,.5)
      z1 = 1./z0
      if (z1 .ne. cmplx(0.,-2)) STOP 1

      z0 = 10.*z0
      if (z0 .ne. cmplx(0.,5.)) STOP 2

      z2 = cmplx(1.,2.)
      z1 = z0/z2
      if (z1 .ne. cmplx(2.,1.)) STOP 3

      z1 = z0*z2
      if (z1 .ne. cmplx(-10.,5.)) STOP 4
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa,
     &     pt2_lim,M2)
!
!     For restrictor elements A1<A2
!     if A1 is critical, pt2 can be as low as possible without any effect on the flow
!     it is necessary to compute pt2_lim which satisfies the element equation
!
!     xflow*dsqrt(R*Tt1)/(A1*Pt1*dsqrt(kappa)-dsqrt(2/(kappa-1)*(Pt1/Pt2)
!     **((kappa-1)-1))/(zeta*kappa)))/(Pt1/Pt2)**((kappa+1)/(2*zeta*kappa))=0
!
!     **Changed 15.11.2007**
!     since we are in the case A1<=A2
!     Pt1/Pt2=(1+0.5*(k-1)M1**2)**(zeta*kappa/(kappa-1))
!     A1 is critical M1=1 which simplifies the previous equation
!     (Pt1/Pt2)_crit=(1+0.5*(k-1))**(zeta*kappa/(kappa-1))
!     It is then possible to determine pt2_lim knowing zeta and Pt1
!
!     Once Pt2_lim is calculated it is possible in turn to calculate
!     the corresponding Mach number M2 satisfying the flow equation
!     for section A2 in terms of M2
!     xflow*dsqrt(R*Tt2)/(A2*Pt2*dsqrt(kappa))-M2/(1+(kappa-1)/2*M2**2)
!     **(0.5*(kappa+1)/(kappa-1))
!
!     author: Yannick Muller
!
      implicit none
!
      integer i
!
      real*8 pt1,Tt2,xflow,zeta,r,kappa,pt2_lim,M2,Qred,expon1,
     &     expon2,root,a2,f,df,pt2,km1,kp1,pt1pt2
!
!     **changed 15.11.2006**
      pt2=0.99d0*pt1
      pt1pt2=pt1/pt2
      km1=kappa-1.d0
      kp1=kappa+1.d0
      expon1=-0.5d0*(kp1)/(zeta*kappa)
      expon2=(km1)/(zeta*kappa)
      root=2.d0/(km1)*((pt1pt2)**expon2-1.d0)
      Qred=dsqrt(kappa/R)*(pt1pt2)**(-0.5d0*kp1/(kappa*zeta))
     &     *dsqrt(2.d0/km1*((pt1pt2)**(km1/(kappa*zeta))-1.d0))
!
      pt2_lim=pt1/(1.d0+0.5d0*(km1))**(zeta*kappa/(km1))

!
!     M2_lim calculation
!
      M2=0.5d0
      expon1=-0.5d0*(kp1)/(km1)
      Qred=dabs(xflow)*dsqrt(R*Tt2)/(A2*pt2_lim*dsqrt(kappa))
      if(Qred.gt.((1.d0+0.5d0*(km1))**expon1)) then
         Qred=(1.d0+0.5d0*(km1))**expon1
      endif
!
      do
         root=(1.d0+0.5d0*(km1)*M2**2.d0)
         f=Qred-M2*root**(expon1)
!
         df=root**expon1*(-1d0+0.5d0*(kp1)*M2**2.d0*root**-1.d0)
!
         if(dabs(-f/df).le.1d-6) then
            M2=M2-f/df

            exit
         endif
!
         M2=M2-f/df
      enddo
!
      return
      end


module array_manipulation
  integer :: VERTICAL = 0
  integer :: HORIZONTAL = 1

contains
  function zeros(x,y) result(result)
    integer:: x,y
    integer, dimension(x,y) :: result

    do i_x=1,x
       do i_y=1,y
          result(i_x, i_y) = 0
       end do
    end do
  end function

  subroutine print_map(map)
    integer, dimension(:,:) :: map
    integer, dimension(2) :: the_shape

    the_shape = shape(map)
    print*, "Shape :", the_shape

    do i=1,the_shape(1)
       print*, map(i,:)
    end do
  end subroutine

  subroutine convolve(array, kernel, horizontal_mirror, vertical_mirror, factor)
    integer, dimension(:,:):: array, kernel
    logical :: horizontal_mirror, vertical_mirror
    integer, dimension(2) :: array_shape, kernel_shape
    integer, pointer :: original_array(:,:)
    integer :: factor

    allocate(original_array, source=array)
    array_shape = shape(array)

    do kernel_center_row = 1, array_shape(1)
       do kernel_center_col = 1, array_shape(2)
          array(kernel_center_row, kernel_center_col) = kernel_sum(kernel_center_row, &
               kernel_center_col, original_array, kernel, horizontal_mirror, vertical_mirror) / factor
       end do
    end do

    deallocate(original_array)
  end subroutine

    integer function kernel_sum(kernel_center_row, kernel_center_col, array, kernel, horizontal_mirror, vertical_mirror)
    integer :: kernel_center_row, kernel_center_col
    integer, dimension(:,:) :: array, kernel
    logical :: horizontal_mirror, vertical_mirror
    integer, dimension(2):: kernel_shape, array_shape
    integer :: tile_row, tile_col, row_offset, column_offset

    array_shape = shape(array)
    kernel_shape = shape(kernel)

    kernel_sum = 0
    do kernel_row=1,kernel_shape(1)
       do kernel_column=1,kernel_shape(2)
          row_offset = kernel_row - ceiling(kernel_shape(1) / 2.0)
          column_offset = kernel_column - ceiling(kernel_shape(2) / 2.0)

          tile_row = offset_tile(kernel_center_row, row_offset, vertical_mirror, array_shape(1))
          tile_col = offset_tile(kernel_center_col, column_offset, horizontal_mirror, array_shape(2))

          kernel_sum = kernel_sum + kernel(kernel_row, kernel_column)*array(tile_row, tile_col)
       end do
    end do
  end function

  integer function offset_tile(base, offset, mirror, max_value)
    integer :: base, offset, max_value
    logical :: mirror

    offset_tile = base + offset

    if (offset_tile > max_value) then
       if (mirror) then
          offset_tile = 2 * max_value - offset_tile
       else
          offset_tile = offset_tile - max_value
       end if
    end if

    if (offset_tile < 1) then
       if (mirror) then
          offset_tile = 2 - offset_tile
       else
          offset_tile = offset_tile + max_value
       end if
    end if
  end function

  function concatenate(array1, array2, axis) result(result)
    integer, dimension(:,:) :: array1, array2
    integer :: axis
    integer, allocatable :: result(:,:)
    integer :: rows, columns
    integer, dimension(2) :: shape1, shape2
    integer :: copy_cursor
    copy_cursor = 1

    shape1 = shape(array1)
    shape2 = shape(array2)

    if (axis == VERTICAL) then
       rows = shape1(1) + shape2(1)
       columns = shape1(2)
    else
       rows = shape1(1)
       columns = shape1(2) + shape2(2)
    end if

    allocate(result(rows, columns))

    if (axis == VERTICAL) then
       do n=1,shape1(1)
          result(copy_cursor, :) = array1(n, :)
          copy_cursor = copy_cursor + 1
       end do
       do n=1, shape2(1)
          result(copy_cursor, :) = array2(n, :)
          copy_cursor = copy_cursor + 1
       end do
    else
       do n=1,shape1(2)
          result(:, copy_cursor) = array1(:,n)
          copy_cursor = copy_cursor + 1
       end do
       do n=1, shape2(2)
          result(:, copy_cursor) = array2(:,n)
          copy_cursor = copy_cursor + 1
       end do
    end if
  end function

  function horizontal_flip(array) result(result)
    integer, dimension(:,:) :: array
    integer, allocatable :: result(:,:)
    integer, dimension(2) :: shape_
    integer :: copy_cursor, col

    shape_ = shape(array)

    allocate(result, mold=array)

    copy_cursor = 1
    do col=shape_(2), 1, -1
       result(:, copy_cursor) = array(:, col)
       copy_cursor = copy_cursor + 1
    end do
  end function

  function vertical_flip(array) result(result)
    integer, dimension(:,:) :: array
    integer, allocatable :: result(:,:)
    integer, dimension(2) :: shape_
    integer :: copy_cursor, row

    shape_ = shape(array)

    allocate(result, mold=array)

    copy_cursor = 1
    do row=shape_(1), 1, -1
       result(copy_cursor, :) = array(row, :)
       copy_cursor = copy_cursor + 1
    end do
  end function

end module


program test_convert_wb_and_bt
  use mod_orrb
  implicit none

  !
  ! Note: This does not cover large rank cases (e.g. ubw=n-1).
  !

  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', lbw: ',I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  integer(kind=int32) :: na, ubwa, lbwa
  type(error_info) :: error
  real(kind=dp), parameter :: tol=1e-15, c=2.0
  !
  real(kind=dp), dimension(:,:), allocatable :: a0_d, a1_d
  complex(kind=dp), dimension(:,:), allocatable :: a0_z, a1_z

  type(d_wb), allocatable :: wb_d
  type(z_wb), allocatable :: wb_z
  type(d_bt), allocatable :: bt_d
  type(z_bt), allocatable :: bt_z

  call initialize_errors

  print *
  print *, "--------------------------------"
  print *
  print *, "Real WB and BT Conversion Tests:"
  print *
  na=40
  lbwa=5; ubwa=3
  wb_d=d_random_wb(na,lbwa,ubwa,error=error)
  a0_d=general(wb_d,error)
  call cpu_time(t0)
  bt_d=bt_of(wb_d,error)
  call cpu_time(t1)
  a1_d=general(bt_d,error)
  test_name = "Real WB to BT, n=40;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,bt_d%lbw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  wb_d=d_random_wb(na,lbwa,ubwa,error=error)
  a0_d=general(wb_d,error)
  call cpu_time(t0)
  bt_d=bt_of(wb_d,error)
  call cpu_time(t1)
  a1_d=general(bt_d,error)
  test_name = "Real WB to BT, n=1;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,bt_d%lbw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  wb_d=d_random_wb(na,lbwa,ubwa,error=error)
  a0_d=general(wb_d,error)
  call cpu_time(t0)
  bt_d=bt_of(wb_d,error)
  call cpu_time(t1)
  a1_d=general(bt_d,error)
  test_name = "Real WB to BT, n=2;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,bt_d%lbw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  wb_d=d_random_wb(na,lbwa,ubwa,error=error)
  a0_d=general(wb_d,error)
  call cpu_time(t0)
  bt_d=bt_of(wb_d,error)
  call cpu_time(t1)
  a1_d=general(bt_d,error)
  test_name = "Real WB to BT, n=3;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,bt_d%lbw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  wb_d=d_random_wb(na,lbwa,ubwa,error=error)
  a0_d=general(wb_d,error)
  call cpu_time(t0)
  bt_d=bt_of(wb_d,error)
  call cpu_time(t1)
  a1_d=general(bt_d,error)
  test_name = "Real WB to BT, n=4;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,bt_d%lbw,t0,t1,c*tol,error)
  print *

  na=40
  lbwa=5; ubwa=3
  bt_d=d_random_bt(na,lbwa,ubwa,error=error)
  a0_d=general(bt_d,error)
  call cpu_time(t0)
  wb_d=wb_of(bt_d,error)
  call cpu_time(t1)
  a1_d=general(wb_d,error)
  test_name = "Real BT to WB, n=40;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wb_d%lbw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  bt_d=d_random_bt(na,lbwa,ubwa,error=error)
  a0_d=general(bt_d,error)
  call cpu_time(t0)
  wb_d=wb_of(bt_d,error)
  call cpu_time(t1)
  a1_d=general(wb_d,error)
  test_name = "Real BT to WB, n=1;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wb_d%lbw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  bt_d=d_random_bt(na,lbwa,ubwa,error=error)
  a0_d=general(bt_d,error)
  call cpu_time(t0)
  wb_d=wb_of(bt_d,error)
  call cpu_time(t1)
  a1_d=general(wb_d,error)
  test_name = "Real BT to WB, n=2;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wb_d%lbw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  bt_d=d_random_bt(na,lbwa,ubwa,error=error)
  a0_d=general(bt_d,error)
  call cpu_time(t0)
  wb_d=wb_of(bt_d,error)
  call cpu_time(t1)
  a1_d=general(wb_d,error)
  test_name = "Real BT to WB, n=3;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wb_d%lbw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  bt_d=d_random_bt(na,lbwa,ubwa,error=error)
  a0_d=general(bt_d,error)
  call cpu_time(t0)
  wb_d=wb_of(bt_d,error)
  call cpu_time(t1)
  a1_d=general(wb_d,error)
  test_name = "Real BT to WB, n=4;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wb_d%lbw,t0,t1,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Complex WB and BT Conversion Tests:"
  print *

  na=40
  lbwa=5; ubwa=3
  wb_z=z_random_wb(na,lbwa,ubwa,error=error)
  a0_z=general(wb_z,error)
  call cpu_time(t0)
  bt_z=bt_of(wb_z,error)
  call cpu_time(t1)
  a1_z=general(bt_z,error)
  test_name = "Complex WB to BT, n=40;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,bt_z%lbw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  wb_z=z_random_wb(na,lbwa,ubwa,error=error)
  a0_z=general(wb_z,error)
  call cpu_time(t0)
  bt_z=bt_of(wb_z,error)
  call cpu_time(t1)
  a1_z=general(bt_z,error)
  test_name = "Complex WB to BT, n=1;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,bt_z%lbw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  wb_z=z_random_wb(na,lbwa,ubwa,error=error)
  a0_z=general(wb_z,error)
  call cpu_time(t0)
  bt_z=bt_of(wb_z,error)
  call cpu_time(t1)
  a1_z=general(bt_z,error)
  test_name = "Complex WB to BT, n=2;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,bt_z%lbw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  wb_z=z_random_wb(na,lbwa,ubwa,error=error)
  a0_z=general(wb_z,error)
  call cpu_time(t0)
  bt_z=bt_of(wb_z,error)
  call cpu_time(t1)
  a1_z=general(bt_z,error)
  test_name = "Complex WB to BT, n=3;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,bt_z%lbw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  wb_z=z_random_wb(na,lbwa,ubwa,error=error)
  a0_z=general(wb_z,error)
  call cpu_time(t0)
  bt_z=bt_of(wb_z,error)
  call cpu_time(t1)
  a1_z=general(bt_z,error)
  test_name = "Complex WB to BT, n=4;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,bt_z%lbw,t0,t1,c*tol,error)
  print *

  na=40
  lbwa=5; ubwa=3
  bt_z=z_random_bt(na,lbwa,ubwa,error=error)
  a0_z=general(bt_z,error)
  call cpu_time(t0)
  wb_z=wb_of(bt_z,error)
  call cpu_time(t1)
  a1_z=general(wb_z,error)
  test_name = "Complex BT to WB, n=40;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wb_z%lbw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  bt_z=z_random_bt(na,lbwa,ubwa,error=error)
  a0_z=general(bt_z,error)
  call cpu_time(t0)
  wb_z=wb_of(bt_z,error)
  call cpu_time(t1)
  a1_z=general(wb_z,error)
  test_name = "Complex BT to WB, n=1;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wb_z%lbw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  bt_z=z_random_bt(na,lbwa,ubwa,error=error)
  a0_z=general(bt_z,error)
  call cpu_time(t0)
  wb_z=wb_of(bt_z,error)
  call cpu_time(t1)
  a1_z=general(wb_z,error)
  test_name = "Complex BT to WB, n=2;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wb_z%lbw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  bt_z=z_random_bt(na,lbwa,ubwa,error=error)
  a0_z=general(bt_z,error)
  call cpu_time(t0)
  wb_z=wb_of(bt_z,error)
  call cpu_time(t1)
  a1_z=general(wb_z,error)
  test_name = "Complex BT to WB, n=3;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wb_z%lbw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  bt_z=z_random_bt(na,lbwa,ubwa,error=error)
  a0_z=general(bt_z,error)
  call cpu_time(t0)
  wb_z=wb_of(bt_z,error)
  call cpu_time(t1)
  a1_z=general(wb_z,error)
  test_name = "Complex BT to WB, n=4;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wb_z%lbw,t0,t1,c*tol,error)

contains

    subroutine d_output_result(name,a0,a1,lbw0,lbw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,lbw0,lbw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_convert_wb_and_bt


program KNAPSACK_CONTINUOUS
  implicit none

  real, parameter :: maxweight = 15.0
  real :: total_weight = 0, total_value = 0, frac
  integer :: i, j

  type Item
    character(7) :: name
    real :: weight
    real :: value
  end type Item

  type(Item) :: items(9), temp

  items(1) = Item("beef",    3.8, 36.0)
  items(2) = Item("pork",    5.4, 43.0)
  items(3) = Item("ham",     3.6, 90.0)
  items(4) = Item("greaves", 2.4, 45.0)
  items(5) = Item("flitch",  4.0, 30.0)
  items(6) = Item("brawn",   2.5, 56.0)
  items(7) = Item("welt",    3.7, 67.0)
  items(8) = Item("salami",  3.0, 95.0)
  items(9) = Item("sausage", 5.9, 98.0)

  ! sort items in descending order of their value per unit weight
  do i = 2, size(items)
     j = i - 1
     temp = items(i)
     do while (j>=1 .and. items(j)%value / items(j)%weight < temp%value / temp%weight)
       items(j+1) = items(j)
       j = j - 1
     end do
    items(j+1) = temp
  end do

  i = 0
  write(*, "(a4, a13, a6)") "Item", "Weight", "Value"
  do while(i < size(items) .and. total_weight < maxweight)
    i = i + 1
    if(total_weight+items(i)%weight < maxweight) then
      total_weight = total_weight + items(i)%weight
      total_value = total_value + items(i)%value
      write(*, "(a7, 2f8.2)") items(i)
    else
      frac = (maxweight-total_weight) / items(i)%weight
      total_weight = total_weight + items(i)%weight * frac
      total_value = total_value + items(i)%value * frac
      write(*, "(a7, 2f8.2)") items(i)%name, items(i)%weight * frac, items(i)%value * frac
    end if
  end do

  write(*, "(f15.2, f8.2)") total_weight, total_value

end program KNAPSACK_CONTINUOUS


*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Program d_snrr
* to determine the SNR in the frequency space of an experimental image,
* for which the square modulus is known.
*
* INPUT:
*   Square modulus
* OUTPUT
*
*	- tableau SNR de nx*ny elements		*.SNR
*	- tableau du majorant du bruit en frequences spatiales  *.SIG
*	- recapitulation des parametres de SNR dans le fichier  *.SUM
*
*
* JLP (modif midas...)
* Version 02-10-91
*-------------------------------------------------------------------------------
	program d_snrr
	real*4 lth
	character*40 filein,filesum,filesnr,filesig
	integer*4 nx,ny,pntrin,pntrsnr,pntrsig
	integer*4 n,long,lu
	character name*40,comments*80
	integer*4 madrid(1)
	common /vmr/madrid
*
* Initialisation
	call jlp_begin
	call jlp_inquifmt
        write(6,102)
102     format('******* Program d_snrr  Version 02-10-91')

*
* Reading square modulus
*
	write(6,*) ' Input file with the square modulus:'
	filein=' '
	call jlp_vm_readimag(pntrin,nx,ny,filein,comments)
	call recentre(madrid(pntrin),madrid(pntrin),nx,ny,nx)
*
* Fabrication de la chaine de caracteres "NAME"
*
55	write(6,*) ' Generic name for the output ? (dot at the end)'
	read(5,10) name
	long=index(name,'.')-1
	if(long.le.0)goto 55
10	format(a)
*
* Ouverture du fichier <name>.SUM
*
	lu=1
	filesum = Name(:long)//'.SUM'
	open(1,file=filesum,status='unknown',access='sequential')
*
* Prenons quelques notes...
*
	write (lu,980)
980	format(/,' MODULE D_SNRR',/,' ----------',/)
	write (lu,981) filein
981	format(' Square modulus : ',A)
*
	write (6,501)
501	format (' Lower threshold of the modulus ?')
	read(5,*) lth

	write (lu,500) lth
500	format (' Lower threshold:',G12.5)
*
	n = nx*ny
*
* on reserve de la place en REAL*4
	nn=n*4
	call jlp_getvm(pntrsnr,nn)
	call jlp_getvm(pntrsig,nn)
*
* Calcul du Rapport Signal/Bruit dans l'Espace des Frequences
*
	call rsb(madrid(pntrin),madrid(pntrsig),madrid(pntrsnr),n,lth)
*
* Output of the images:
*
	filesnr = Name(:long)//'.SNR'
	comments = 'SNR (in the Fourier domain) of:'//fileIn
	call jlp_writeimag(madrid(pntrsnr),nx,ny,nx,
     1	filesnr,comments)
*
* ouverture du fichier .SIG
*
	filesig = Name(:long)//'.SIG'
	comments = 'Sigma (in Fourier domain) of:'//fileIn
	call jlp_writeimag(madrid(pntrsig),nx,ny,nx,
     1	filesig,comments)
*
	close(lu)
*
*
* Sortie normale
*
	call jlp_end
	stop
 	end
*
*-------------------------------------------------------------------------------
*
 	subroutine rsb(modsq,sigma_i,snr,n,lth)
*
* Calcule le rapport Signal/Bruit
*
	real*4 lth,value,modsq_min
	integer*4 n,i
	real*4	modsq(*),sigma_i(*),snr(*)
*
	modsq_min=lth*lth
	print *,' modsq_min',modsq_min
	do i = 1,n
	 value=modsq(i)
	 if(value.gt.modsq_min) then
	   snr(i) = sqrt(value)/lth
	   sigma_i(i)=1./snr(i)
	  else
	   snr(i)=0.
	   sigma_i(i)=1.E06
	  endif
	end do
*
	return
	end
C-----------------------------------------------------------------------------
C	include 'd_utilities.for'
C Contains recentre:
C	include 'fft_jlp.for'


! *****************************COPYRIGHT*******************************
! (C) Crown copyright Met Office. All rights reserved.
! For further details please refer to the file COPYRIGHT.txt
! which you should have received as part of this distribution.
! *****************************COPYRIGHT*******************************
!
! This file is part of the UM Shared Library project.
!
! The UM Shared Library is free software: you can redistribute it
! and/or modify it under the terms of the Modified BSD License, as
! published by the Open Source Initiative.
!
! The UM Shared Library is distributed in the hope that it will be
! useful, but WITHOUT ANY WARRANTY; without even the implied warranty
! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! Modified BSD License for more details.
!
! You should have received a copy of the Modified BSD License
! along with the UM Shared Library.
! If not, see <http://opensource.org/licenses/BSD-3-Clause>.
!
!*******************************************************************************
!
! Description : Water related physical constants

MODULE f_shum_water_constants_mod

USE, INTRINSIC :: ISO_C_BINDING, ONLY:                   &
  C_DOUBLE

IMPLICIT NONE

PRIVATE

PUBLIC :: shum_tfs_const,         shum_tm_const,          &
          shum_rho_water_const,   shum_rhosea_const,      &
          shum_rho_ice_const,     shum_lc_const,          &
          shum_lf_const,          shum_hcapv_const,       &
          shum_hcapw_const,       shum_hcapi_const,       &
          shum_dpsidt_const

!------------------------------------------------------------------------------!
! We're going to use the types from the ISO_C_BINDING module, since although   !
! the REALs aren't 100% guaranteed to correspond to the sizes we want to       !
! enforce, they should be good enough on the majority of systems.              !
!                                                                              !
! Additional protection for the case that FLOAT/DOUBLE do not conform to the   !
! sizes we expect is provided via the "precision_bomb" macro-file              !
!------------------------------------------------------------------------------!
INTEGER, PARAMETER :: real64 = C_DOUBLE
!------------------------------------------------------------------------------!

! tfs, temperature at which sea water freezes
REAL(KIND=real64), PARAMETER :: shum_tfs_const         = 271.35_real64
! tm, temperature at which fresh water freezes and ice melts
REAL(KIND=real64), PARAMETER :: shum_tm_const          = 273.15_real64

! density of pure water (kg/m3)
REAL(KIND=real64), PARAMETER :: shum_rho_water_const   = 1000.0_real64
! density of sea water (kg/m3)
REAL(KIND=real64), PARAMETER :: shum_rhosea_const      = 1026.0_real64
! Density of ice (kg/m3)
REAL(KIND=real64), PARAMETER :: shum_rho_ice_const     = 917.0_real64

! latent heat of condensation of water at 0degc
REAL(KIND=real64), PARAMETER :: shum_lc_const          = 2.501e6_real64
! latent heat of fusion of water at 0degc
REAL(KIND=real64), PARAMETER :: shum_lf_const          = 0.334e6_real64

! Specific heat capacity of water vapour (J/kg/K)
REAL(KIND=real64), PARAMETER :: shum_hcapv_const       = 1850.0_real64
! Specific heat capacity of water (J/kg/K)
REAL(KIND=real64), PARAMETER :: shum_hcapw_const       = 4180.0_real64
! Specific heat capacity of ice (J/kg/K)
REAL(KIND=real64), PARAMETER :: shum_hcapi_const       = 2100.0_real64

! Rate of change of ice potential with temperature
! RHO_ICE*LF/ZERODEGC*1/(RHO_WATER*G) (m/K)
REAL(KIND=real64), PARAMETER :: shum_dpsidt_const      = 114.3_real64

END MODULE f_shum_water_constants_mod


program sistu_ppal

use sistub_interface
use datasissim_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: r

integer :: n

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), b(n), u(n))

u = 0

call datasissim(a, b)
call sistub(a, b, u)

print*,
print*, 'Vector u: '
print*,

print*,
print*, u
print*,

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

end program


      program som
      implicit none
c
      integer n, i, sum
      double precision r
c
      sum = 0
      write (*,*) 'How many terms ?'
      read *, n

      do i = 1, n
        sum = sum + i
        r = sum / n
        write (*,*) 'Sum = ', sum, ' and the average = ', r
      enddo
c
      end


program internals_test
    use internals_mod
    implicit none
    integer, parameter :: n = 5
    integer :: i
    real, parameter :: x_min = 0.0, x_delta = 0.1
    real :: x
    real, dimension(n) :: values

    call compute()
    print "(5F7.3)", values
    call compute_more(n, x)
    print "(A, F15.7)", 'program x = ', x

contains

    subroutine compute()
        implicit none
        real :: x

        x = x_min
        do i = 1, n
            values(i) = cos(2.0*3.14*x)
            x = x + x_delta
        end do
    end subroutine compute

end program internals_test


module Ackp

implicit none (type, external)

contains

recursive pure integer function Ap(m, n) result(A)
integer, intent(in) :: m,n

if (m == 0) then
  A = n+1
elseif (n == 0) then
  A = Ap(m-1, 1)
else
  A = Ap(m-1, Ap(m, n-1))
end if
end function Ap

end module Ackp

program AckermannPeter

use Ackp

implicit none (type, external)

integer :: Ack, M, N
character(8) :: buf

if (command_argument_count() /= 2) stop 'input M,N positive integers'

call get_command_argument(1, buf)
read(buf,*) M

call get_command_argument(2, buf)
read(buf, *) N

Ack = Ap(M, N)

print *, Ack
end program AckermannPeter


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    use toolbox

    implicit none

    ! number of years the household retires
    integer, parameter :: JR = 45

    ! number of years the household lives
    integer, parameter :: JJ = 80

    ! number of persistent shock process values
    integer, parameter :: NP = 2

    ! number of transitory shock process values
    integer, parameter :: NS = 5

    ! number of points on the asset grid
    integer, parameter :: NA = 80

    ! number of points on the human capital grid
    integer, parameter :: NH = 60

    ! household preference parameters
    real*8, parameter :: gamma = 0.50d0
    real*8, parameter :: egam  = 1d0 - 1d0/gamma
    real*8, parameter :: nu    = 0.12d0
    real*8, parameter :: beta  = 0.98d0

    ! household risk process
    real*8, parameter :: sigma_theta = 0.242d0
    real*8, parameter :: sigma_eps   = 0.022d0
    real*8, parameter :: rho         = 0.985d0

    ! parameters governing the human capital process of women
    real*8, parameter :: xi(2) = (/0.05312d0, -0.00188d0/)
    real*8, parameter :: del_h = 0.074d0

    ! size of the asset grid
    real*8, parameter :: a_l    = 0.0d0
    real*8, parameter :: a_u    = 450d0
    real*8, parameter :: a_grow = 0.05d0

    ! size of the human capital grid
    real*8 :: h_l, h_u
    real*8, parameter :: h_grow = 0.03d0

    ! maximum values of a and h by year
    real*8 :: a_max(JJ), h_max(JJ)

    ! net prices
    real*8 :: r, w_m, w_f

    ! transfer payments (old-age) and survival probabilities
    real*8 :: pen(JJ), psi(JJ+1)

    ! cohort aggregate variables
    real*8 :: c_coh(JJ), ym_coh(JJ), yf_coh(JJ), l_coh(JJ)
    real*8 :: a_coh(JJ), h_coh(JJ), v_coh(JJ)
    real*8 :: cv_c(JJ), cv_y(JJ)

    ! the permanent shock process
    real*8 :: dist_theta(NP), theta(NP)

    ! variables related to children
    integer :: nchild(JJ)
    real*8  :: pchild(JJ)

    ! the transitory shock process
    real*8 :: pi(NS, NS), eta(NS)
    integer :: is_initial = 3

    ! demographic and other model parameters
    real*8 :: eff(JJ)

    ! individual variables
    real*8 :: a(0:NA), h(0:NH), aplus(JJ, 0:NA, 0:NH, NP, NS, NS)
    real*8 :: c(JJ, 0:NA, 0:NH, NP, NS, NS), l(JJ, 0:NA, 0:NH, NP, NS, NS)
    real*8 :: phi(JJ, 0:NA, 0:NH, NP, NS, NS), V(JJ, 0:NA, 0:NH, NP, NS, NS) = 0d0

    ! numerical variables
    real*8 :: RHS(0:NA, 0:NH, NP, NS, NS, 0:1), EV(0:NA, 0:NH, NP, NS, NS, 0:1)
    integer :: ij_com, ia_com, ih_com, ip_com, ism_com, isf_com, il_com
    real*8 :: cons_com

contains

    ! the first order condition
    function foc(x)

        implicit none
        real*8, intent(in) :: x
        real*8 :: foc, a_plus, varphi, tomorrow, wage_m, wage_f
        integer :: ial, iar

        ! calculate tomorrows assets
        a_plus  = x

        ! calculate wages (incl. child care costs) of men and women
        wage_m = w_m*eff(ij_com)*theta(ip_com)*eta(ism_com)
        wage_f = w_f*dble(il_com)*(exp(h(ih_com))*theta(ip_com)*eta(isf_com) - pchild(ij_com))

        ! calculate consumption
        cons_com = (1d0+r)*a(ia_com) + pen(ij_com) + wage_f + wage_m - a_plus

        ! calculate linear interpolation for future part of first order condition
        a_plus = max(a_plus, a_l)
        call linint_Grow(a_plus, a_l, a_u, a_grow, NA, ial, iar, varphi)

        tomorrow = varphi*RHS(ial, ih_com, ip_com, ism_com, isf_com, il_com) + &
                  (1d0-varphi)*RHS(iar, ih_com, ip_com, ism_com, isf_com, il_com)

        ! calculate first order condition for consumption
        foc = cons_com/sqrt(2d0+dble(nchild(ij_com)))**(1d0-gamma) - tomorrow

    end function

    ! calculates marginal utility of consumption
    function margu(cons, ij)

        implicit none
        real*8, intent(in) :: cons
        integer, intent(in) :: ij
        real*8 :: margu

        margu = cons**(-1d0/gamma)/sqrt(2d0+dble(nchild(ij)))**egam

    end function

    ! calculates the value function
    function valuefunc(a_plus, cons, lpart, ij, ih, ip, ism, isf)

        implicit none
        integer, intent(in) :: lpart, ij, ih, ip, ism, isf
        real*8, intent(in) :: a_plus, cons
        real*8 :: valuefunc, varphi, c_help
        integer :: ial, iar

        ! check whether consumption or leisure are too small
        c_help = max(cons, 1d-10)

        ! get tomorrows utility
        call linint_Grow(a_plus, a_l, a_u, a_grow, NA, ial, iar, varphi)

        ! calculate tomorrow's part of the value function
        valuefunc = 0d0
        if(ij < JJ)then
            valuefunc = max(varphi*EV(ial, ih, ip, ism, isf, lpart) + &
                (1d0-varphi)*EV(iar, ih, ip, ism, isf, lpart), 1d-10)**egam/egam
        endif

        ! add todays part and discount
        valuefunc = (c_help/sqrt(2d0+dble(nchild(ij))))**egam/egam &
                        - nu*dble(lpart) + beta*psi(ij+1)*valuefunc

    end function

end module


program main

use test, only: test_value
use io, only: stdout

use earth

implicit none
double precision :: xyz_pole(3), geo_pole(3), x, y, z, lon, lat, h
integer :: ierr

! Calculate the pole of ITRF08 reference frame with respect to MORVEL56 no-net-rotation frame
! call itrf2008_wrt_morvel56_PA()
! call pole_xyz2geo(-0.190d0,-0.442d0,0.915d0,lon,lat,mag)
! write(0,*) lon,lat,mag*masa2degma
! call pole_xyz2geo(-0.252d0,-0.302d0,0.643d0,lon,lat,mag)
! write(0,*) lon,lat,mag*masa2degma

! pole_xyz2geo
xyz_pole(1) = -0.190d0
xyz_pole(2) = -0.442d0
xyz_pole(3) =  0.915d0
call pole_xyz2geo(xyz_pole(1),xyz_pole(2),xyz_pole(3),geo_pole(1),geo_pole(2),geo_pole(3),'sphere')
call test_value(geo_pole(1),-113.26114046643323d0,'pole_xyz2geo: geo_pole(1)')
call test_value(geo_pole(2), 62.264603563491839d0,'pole_xyz2geo: geo_pole(2)')
call test_value(geo_pole(3), 1.0337741532849427d0,'pole_xyz2geo: geo_pole(3)')
call test_value(geo_pole(3)*masa2degma,0.28715948702359523d0,'masa2degma')

! pole_geo2xyz
call pole_geo2xyz(geo_pole(1),geo_pole(2),geo_pole(3),xyz_pole(1),xyz_pole(2),xyz_pole(3),'sphere')
call test_value(xyz_pole(1),-0.190d0,'pole_geo2xyz: xyz_pole(1)')
call test_value(xyz_pole(2),-0.442d0,'pole_geo2xyz: xyz_pole(2)')
call test_value(xyz_pole(3), 0.915d0,'pole_geo2xyz: xyz_pole(3)')

! get_pole
call get_pole('NA','EU','MORVEL',geo_pole,ierr)
call test_value(geo_pole(1), 139.46111978128923d0,'get_pole: MORVEL NA/EU lon')
call test_value(geo_pole(2), 61.796375604003913d0,'get_pole: MORVEL NA/EU lat')
call test_value(geo_pole(3),0.21067757026307590d0,'get_pole: MORVEL NA/EU vel (deg/Ma)')

! sphere_geo2xyz
! sphere_xyz2geo

! ellipsoid_geo2xyz
lon = 1.4223653911d+02
lat = 4.3889293271d+01
h = 1.7767427755d+02
call ellipsoid_geo2xyz(lon,lat,h,x,y,z,semimajor_grs80,eccentricity_grs80)
call test_value(x,-3.6397836984d+06,'ellipsoid_geo2xyz: x')
call test_value(y,2.8195896747d+06,'ellipsoid_geo2xyz: y')
call test_value(z,4.3993581171d+06,'ellipsoid_geo2xyz: z')
! -3.6397836984E+06  2.8195896747E+06  4.3993581171E+06

! ellipsoid_xyz2geo
x = -3.6397836984d+06
y =  2.8195896747d+06
z =  4.3993581171d+06
call ellipsoid_xyz2geo(x,y,z,lon,lat,h,semimajor_grs80,eccentricity_grs80,10)
call test_value(lon,1.4223653911d+02,'ellipsoid_xyz2geo: lon')
call test_value(lat,4.3889293271d+01,'ellipsoid_xyz2geo: lat')
call test_value(h,1.7767427755d+02,'ellipsoid_xyz2geo: height')

write(stdout,*) 'earth_module unit test passed'
end


c
c non central cumulative f distribution
c
c Uses ncbeta from AS 310 APPL. STATIST. (1997), VOL. 46, NO. 1
c
      function dncf(f,df1,df2,ncp,ifault)
      implicit none
      real*8 dncf
      real*8 f, df1, df2, ncp
      integer ifault

      real*8 ncbeta
      external ncbeta

      real*8 errmax, y

      errmax = 1.0e-6
      y = (df1 / df2) * f

      dncf=ncbeta(df1/2.0, df2/2.0,ncp,y/(1.0+y),errmax,ifault)

      return
      end

c llmgamma oli ALNGAM
      REAL*8 FUNCTION NCBETA (A, B, LAMBDA, X, ERRMAX, IFAULT)
c
c       ALGORITHM AS 310 APPL. STATIST. (1997), VOL. 46, NO. 1
c
c       Computes the cumulative distribution function of a
c       non-central beta random variable
c
      implicit none
      REAL*8 A, B, LAMBDA, X, ERRMAX
      INTEGER IFAULT
c
      INTEGER XJ, M, I, J, ITER1, ITER2, ITERLO, ITERHI
c
c       Local variable XJ gives the number of iterations taken
c
      REAL*8 FX, GX, TEMP, FTEMP, EBD, ERRBD,
     *  Q, R, S, T, S0, S1, T0, T1, SUM, PSUM,
     *  C, HALF, ONE, ZERO, FIVE, BETA,
     *  lngamma, BETAIN, BETANC, GAMMAD
c
      EXTERNAL lngamma, BETAIN, BETANC, GAMMAD
c
      DATA ZERO, HALF, ONE, FIVE /
     *  0.0d+00, 0.5d+00, 1.0d+00, 5.0d+00 /
c
      NCBETA = X
c
c       Check for admissibility of parameters
c
      IFAULT = 3
      IF (LAMBDA .LE. ZERO .OR. A .LE. ZERO .OR. B .LE. ZERO) RETURN
      IFAULT = 2
      IF (X .LT. ZERO .OR. X .GT. ONE) RETURN
      IFAULT = 1
      IF (X .EQ. ZERO .OR. X .EQ. ONE) RETURN
      IFAULT = 0
c
      C = LAMBDA * HALF
      XJ = ZERO
c
CCCCCCCCCCC ML
c      NCBETA = max(0.0d0,BETANC(X, A, B, LAMBDA, IFAULT))
c      RETURN
CCCCCCCCCCC alla oleva ei toimi !!!

      IF (LAMBDA .LT. 54.0) THEN
c
c       AS 226 as it stands is sufficient in this situation
c
        NCBETA = BETANC(X, A, B, LAMBDA, IFAULT)
        RETURN
      ELSE
        M = INT(C + HALF)
        ITERLO = M - int(FIVE * SQRT(dble(M)))
        ITERHI = M + int(FIVE * SQRT(dble(M)))
        T = - C + M * dLOG(C) - lngamma(M + ONE, ifault)
        Q = EXP(T)
        R = Q
        PSUM = Q

        BETA = lngamma(A+ M,ifault) + lngamma(B,ifault) -
     & lngamma(A+ M +B,ifault)
        S1 = (A + M) * dLOG(X) + B * dLOG(ONE - X)-dLOG(A + M)-BETA
        GX = dEXP(S1)
        FX = GX
        TEMP = BETAIN(X, A + M, B, BETA, IFAULT)
        FTEMP= TEMP
        XJ = XJ + ONE
        SUM = Q - TEMP
        ITER1= M
c
c      The first set of iterations starts from M and goes downwards
c
   20   IF (ITER1 .LT. ITERLO) GO TO 30
        IF (Q .LT. ERRMAX) GO TO 30
        Q = Q - ITER1 / C
        XJ = XJ + ONE
        GX = (A + ITER1) / (X * (A + B + ITER1 - ONE)) * GX
        ITER1= ITER1- ONE
        TEMP =TEMP + GX
        PSUM = PSUM + Q
        SUM = SUM + Q * TEMP
        GO TO 20
   30   T0 = lngamma(A + B,ifault) - lngamma(A + ONE,ifault)
     &   - lngamma(B,ifault)
        S0 = A * dLOG(X) + B * dLOG(ONE - X)
c
        DO 40 I=1, ITER1
          J = I - ONE
          S = S + dEXP(T0 + S0 + J * dLOG(X))
          T1 = dLOG(A + B + J) - dLOG(A + ONE + J) + T0
          T0 = T1
   40   CONTINUE
c
c       Compute the first part of error bound
c
        ERRBD=(ONE- GAMMAD(C,dble(ITER1),IFAULT))*(TEMP + S)
        Q = R
        TEMP = FTEMP
        GX = FX
        ITER2 = M
   50   EBD = ERRBD + (ONE - PSUM) * TEMP
        IF (EBD .LT. ERRMAX .OR. ITER2 .GE. ITERHI) GO TO 60
        ITER2 = ITER2 + ONE
        XJ = XJ + ONE
        Q = Q * C / ITER2
        PSUM = PSUM + Q
        TEMP = TEMP - GX
        GX = X * (A + B + ITER2 - ONE) / (A + ITER2) * GX
        SUM = SUM + Q * TEMP
        GO TO 50
   60   CONTINUE
      END IF
   70 NCBETA = SUM
c
      RETURN
      END

      REAL*8 FUNCTION BETANC(X, A, B, LAMBDA, IFAULT)
C
C     ALGORITHM AS226 APPL. STATIST. (1987) VOL. 36, NO. 2
C     Incorporates modification AS R84 from AS vol. 39, pp311-2, 1990
C
C     Returns the cumulative probability of X for the non-central beta
C     distribution with parameters A, B and non-centrality LAMBDA
C
C     Auxiliary routines required: ALnGAM - log-gamma function (ACM
C     291 or AS 245), and BETAIN - incomplete-beta function (AS 63)
C
      implicit none
      REAL*8 A, AX, B, BETA, C, ERRBD, ERRMAX, GX, HALF, LAMBDA,
     *     ONE, Q, SUMQ, TEMP, X, XJ, ZERO
      REAL*8 A0, X0, UALPHA
      real*8 alngam, betain
      external alngam, betain
      integer itrmax, ifault
C
C     Change ERRMAX and ITRMAX if desired ...
C
      DATA ERRMAX, ITRMAX /1.0E-6, 200/, UALPHA /5.0/
C
      DATA ZERO, HALF, ONE /0.0, 0.5, 1.0/
C
      BETANC = X
C
      IFAULT = 2
      IF (LAMBDA .LT. ZERO .OR. A .LE. ZERO .OR. B .LE. ZERO) RETURN
      IFAULT = 3
      IF (X .LT. ZERO .OR. X .GT. ONE) RETURN
      IFAULT = 0
      IF (X .EQ. ZERO .OR. X .EQ. ONE) RETURN
C
      C = LAMBDA * HALF
C
C     Initialize the series ...
C
      X0 = INT( MAX(C - UALPHA*SQRT(C), ZERO) )
      A0 = A + X0
      BETA = ALnGAM(A0, IFAULT) + ALnGAM(B, IFAULT) -
     *       ALnGAM(A0+B, IFAULT)
      TEMP = BETAIN(X, A0, B, BETA, IFAULT)
      GX = EXP(A0 * LOG(X) + B * LOG(ONE - X) - BETA - LOG(A0))
      IF (A0 .GT. A) THEN
        Q = EXP(-C + X0*LOG(C)) - ALnGAM(X0 + ONE, IFAULT)
      ELSE
        Q = EXP(-C)
      END IF
      XJ = ZERO
      AX = Q * TEMP
      SUMQ = ONE - Q
      BETANC = AX
C
C     Recur over subsequent terms until convergence is achieved...
C
   10 XJ = XJ + ONE
      TEMP = TEMP - GX
      GX = X * (A + B + XJ - ONE) * GX / (A + XJ)
      Q = Q * C / XJ
      SUMQ = SUMQ - Q
      AX = TEMP * Q
      BETANC = BETANC + AX
C
C     Check for convergence and act accordingly...
C
      ERRBD = (TEMP - GX) * SUMQ
      IF ((INT(XJ) .LT. ITRMAX) .AND. (ERRBD .GT. ERRMAX)) GO TO 10
      IF (ERRBD .GT. ERRMAX) IFAULT = 1
C
      RETURN
      END
c This file contains two algorithms for the logarithm of the gamma function.
c Algorithm AS 245 is the faster (but longer) and gives an accuracy of about
c 10-12 significant decimal digits except for small regions around X = 1 and
c X = 2, where the function goes to zero.
c The second algorithm is not part of the AS algorithms.   It is slower but
c gives 14 or more significant decimal digits accuracy, except around X = 1
c and X = 2.   The Lanczos series from which this algorithm is derived is
c interesting in that it is a convergent series approximation for the gamma
c function, whereas the familiar series due to De Moivre (and usually wrongly
c called Stirling's approximation) is only an asymptotic approximation, as
c is the true and preferable approximation due to Stirling.
c
c
c
      DOUBLE PRECISION FUNCTION ALNGAM(XVALUE, IFAULT)
C
C     ALGORITHM AS245  APPL. STATIST. (1989) VOL. 38, NO. 2
C
C     Calculation of the logarithm of the gamma function
C
      INTEGER IFAULT
      DOUBLE PRECISION ALR2PI, FOUR, HALF, ONE, ONEP5, R1(9), R2(9),
     +          R3(9), R4(5), TWELVE, X, X1, X2, XLGE, XLGST, XVALUE,
     +          Y, ZERO
C
C     Coefficients of rational functions
C
      DATA R1/-2.66685 51149 5D0, -2.44387 53423 7D1,
     +        -2.19698 95892 8D1,  1.11667 54126 2D1,
     +         3.13060 54762 3D0,  6.07771 38777 1D-1,
     +         1.19400 90572 1D1,  3.14690 11574 9D1,
     +         1.52346 87407 0D1/
      DATA R2/-7.83359 29944 9D1, -1.42046 29668 8D2,
     +         1.37519 41641 6D2,  7.86994 92415 4D1,
     +         4.16438 92222 8D0,  4.70668 76606 0D1,
     +         3.13399 21589 4D2,  2.63505 07472 1D2,
     +         4.33400 02251 4D1/
      DATA R3/-2.12159 57232 3D5,  2.30661 51061 6D5,
     +         2.74647 64470 5D4, -4.02621 11997 5D4,
     +        -2.29660 72978 0D3, -1.16328 49500 4D5,
     +        -1.46025 93751 1D5, -2.42357 40962 9D4,
     +        -5.70691 00932 4D2/
      DATA R4/ 2.79195 31791 8525D-1, 4.91731 76105 05968D-1,
     +         6.92910 59929 1889D-2, 3.35034 38150 22304D0,
     +         6.01245 92597 64103D0/
C
C     Fixed constants
C
      DATA ALR2PI/9.18938 53320 4673D-1/, FOUR/4.D0/, HALF/0.5D0/,
     +     ONE/1.D0/, ONEP5/1.5D0/, TWELVE/12.D0/, ZERO/0.D0/
C
C     Machine-dependant constants.
C     A table of values is given at the top of page 399 of the paper.
C     These values are for the IEEE double-precision format for which
C     B = 2, t = 53 and U = 1023 in the notation of the paper.
C
      DATA XLGE/5.10D6/, XLGST/1.D+305/
C
      X = XVALUE
      ALNGAM = ZERO
C
C     Test for valid function argument
C
      IFAULT = 2
      IF (X .GE. XLGST) RETURN
      IFAULT = 1
      IF (X .LE. ZERO) RETURN
      IFAULT = 0
C
C     Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined
C
      IF (X .LT. ONEP5) THEN
        IF (X .LT. HALF) THEN
          ALNGAM = -LOG(X)
          Y = X + ONE
C
C     Test whether X < machine epsilon
C
          IF (Y .EQ. ONE) RETURN
        ELSE
          ALNGAM = ZERO
          Y = X
          X = (X - HALF) - HALF
        END IF
        ALNGAM = ALNGAM + X * ((((R1(5)*Y + R1(4))*Y + R1(3))*Y
     +                + R1(2))*Y + R1(1)) / ((((Y + R1(9))*Y + R1(8))*Y
     +                + R1(7))*Y + R1(6))
        RETURN
      END IF
C
C     Calculation for 1.5 <= X < 4.0
C
      IF (X .LT. FOUR) THEN
        Y = (X - ONE) - ONE
        ALNGAM = Y * ((((R2(5)*X + R2(4))*X + R2(3))*X + R2(2))*X
     +              + R2(1)) / ((((X + R2(9))*X + R2(8))*X + R2(7))*X
     +              + R2(6))
        RETURN
      END IF
C
C     Calculation for 4.0 <= X < 12.0
C
      IF (X .LT. TWELVE) THEN
        ALNGAM = ((((R3(5)*X + R3(4))*X + R3(3))*X + R3(2))*X + R3(1)) /
     +            ((((X + R3(9))*X + R3(8))*X + R3(7))*X + R3(6))
        RETURN
      END IF
C
C     Calculation for X >= 12.0
C
      Y = LOG(X)
      ALNGAM = X * (Y - ONE) - HALF * Y + ALR2PI
      IF (X .GT. XLGE) RETURN
      X1 = ONE / X
      X2 = X1 * X1
      ALNGAM = ALNGAM + X1 * ((R4(3)*X2 + R4(2))*X2 + R4(1)) /
     +              ((X2 + R4(5))*X2 + R4(4))
      RETURN
      END
c
c
c
c
        double precision function lngamma(z, ier)
c
c       Uses Lanczos-type approximation to ln(gamma) for z > 0.
c       Reference:
c            Lanczos, C. 'A precision approximation of the gamma
c                    function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
c       Accuracy: About 14 significant digits except for small regions
c                 in the vicinity of 1 and 2.
c
c       Programmer: Alan Miller
c                   CSIRO Division of Mathematics & Statistics
c
c       N.B. It is assumed that the Fortran compiler supports long
c            variable names, including the underline character.   Some
c            compilers will not accept the 'implicit none' statement
c            below.
c
c       Latest revision - 17 April 1988
c
        implicit none
        double precision a(9), z, lnsqrt2pi, tmp
        integer ier, j
        data a/0.9999999999995183d0, 676.5203681218835d0,
     +         -1259.139216722289d0, 771.3234287757674d0,
     +         -176.6150291498386d0, 12.50734324009056d0,
     +         -0.1385710331296526d0, 0.9934937113930748d-05,
     +         0.1659470187408462d-06/
c
        data lnsqrt2pi/0.91893 85332 04672 7d0/
c
        if (z .le. 0.d0) then
          ier = 1
          return
        end if
        ier = 0
c
        lngamma = 0.d0
        tmp = z + 7.d0
        do 10 j = 9, 2, -1
          lngamma = lngamma + a(j)/tmp
          tmp = tmp - 1.d0
   10   continue
        lngamma = lngamma + a(1)
        lngamma = log(lngamma) + lnsqrt2pi - (z+6.5d0) +
     +                               (z-0.5d0)*log(z+6.5d0)
        end
      double precision function betain(x, p, q, beta, ifault)
      implicit double precision (a-h, o-z)
c
c     algorithm as 63  appl. statist. (1973), vol.22, no.3
c
c     computes incomplete beta function ratio for arguments
c     x between zero and one, p and q positive.
c     log of complete beta function, beta, is assumed to be known
c
      logical indx
c
c     define accuracy and initialise
c
      data zero/0.0d0/, one/1.0d0/, acu/0.1d-14/
      betain=x
c
c     test for admissibility of arguments
c
      ifault=1
      if(p.le.zero .or. q.le.zero) return
      ifault=2
      if(x.lt.zero .or. x.gt.one) return
      ifault=0
      if(x.eq.zero .or. x.eq. one) return
c
c     change tail if necessary and determine s
c
      psq=p+q
      cx=one-x
      if(p.ge.psq*x) goto 1
      xx=cx
      cx=x
      pp=q
      qq=p
      indx=.true.
      goto 2
    1 xx=x
      pp=p
      qq=q
      indx=.false.
    2 term=one
      ai=one
      betain=one
      ns=qq+cx*psq
c
c     user soper's reduction formulae.
c
      rx=xx/cx
    3 temp=qq-ai
      if(ns.eq.0) rx=xx
    4 term=term*temp*rx/(pp+ai)
      betain=betain+term
      temp=abs(term)
      if(temp.le.acu .and. temp.le.acu*betain) goto 5
      ai=ai+one
      ns=ns-1
      if(ns.ge.0) goto 3
      temp=psq
      psq=psq+one
      goto 4
c
c     calculate result
c
    5 betain=betain*exp(pp*log(xx)+(qq-one)*log(cx)-beta)/pp
      if(indx) betain=one-betain
      return
      end
	DOUBLE PRECISION FUNCTION GAMMAD(X, P, IFAULT)
C
C	ALGORITHM AS239  APPL. STATIST. (1988) VOL. 37, NO. 3
C
C	Computation of the Incomplete Gamma Integral
C
C	Auxiliary functions required: ALnGAM = logarithm of the gamma
C	function, and ALNORM = algorithm AS66
C
	implicit none
	INTEGER	IFAULT
	DOUBLE PRECISION PN1, PN2, PN3, PN4, PN5, PN6, X, TOL, OFLO,
     *		XBIG, ARG, C, RN, P, A, B, ONE, ZERO, ALnGAM,
     *		AN, TWO, ELIMIT, PLIMIT, ALNORM, THREE, NINE
	PARAMETER (ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0, OFLO = 1.D+37,
     *		THREE = 3.D0, NINE = 9.D0, TOL = 1.D-14, XBIG = 1.D+8,
     *		PLIMIT = 1000.D0, ELIMIT = -88.D0)
	EXTERNAL ALnGAM, ALNORM
C
	GAMMAD = ZERO
C
C	Check that we have valid values for X and P
C
	IF (P .LE. ZERO .OR. X .LT. ZERO) THEN
	  IFAULT = 1
	  RETURN
	END IF
	IFAULT = 0
	IF (X .EQ. ZERO) RETURN
C
C	Use a normal approximation if P > PLIMIT
C
	IF (P .GT. PLIMIT) THEN
	  PN1 = THREE * SQRT(P) * ((X / P) ** (ONE / THREE) + ONE /
     *		(NINE * P) - ONE)
	  GAMMAD = ALNORM(PN1, .FALSE.)
	  RETURN
	END IF
C
C	If X is extremely large compared to P then set GAMMAD = 1
C
	IF (X .GT. XBIG) THEN
	  GAMMAD = ONE
	  RETURN
	END IF
C
	IF (X .LE. ONE .OR. X .LT. P) THEN
C
C	Use Pearson's series expansion.
C	(Note that P is not large enough to force overflow in ALnGAM).
C	No need to test IFAULT on exit since P > 0.
C
	  ARG = P * LOG(X) - X - ALnGAM(P + ONE, IFAULT)
	  C = ONE
	  GAMMAD = ONE
	  A = P
   40	  A = A + ONE
	  C = C * X / A
	  GAMMAD = GAMMAD + C
	  IF (C .GT. TOL) GO TO 40
	  ARG = ARG + LOG(GAMMAD)
	  GAMMAD = ZERO
	  IF (ARG .GE. ELIMIT) GAMMAD = EXP(ARG)
C
	ELSE
C
C	Use a continued fraction expansion
C
	  ARG = P * LOG(X) - X - ALnGAM(P, IFAULT)
	  A = ONE - P
	  B = A + X + ONE
	  C = ZERO
	  PN1 = ONE
	  PN2 = X
	  PN3 = X + ONE
	  PN4 = X * B
	  GAMMAD = PN3 / PN4
   60	  A = A + ONE
	  B = B + TWO
	  C = C + ONE
	  AN = A * C
	  PN5 = B * PN3 - AN * PN1
	  PN6 = B * PN4 - AN * PN2
	  IF (ABS(PN6) .GT. ZERO) THEN
	    RN = PN5 / PN6
	    IF (ABS(GAMMAD - RN) .LE. MIN(TOL, TOL * RN)) GO TO 80
	    GAMMAD = RN
	  END IF
C
	  PN1 = PN3
	  PN2 = PN4
	  PN3 = PN5
	  PN4 = PN6
	  IF (ABS(PN5) .GE. OFLO) THEN
C
C	Re-scale terms in continued fraction if terms are large
C
	    PN1 = PN1 / OFLO
	    PN2 = PN2 / OFLO
	    PN3 = PN3 / OFLO
	    PN4 = PN4 / OFLO
	  END IF
	  GO TO 60
   80	  ARG = ARG + LOG(GAMMAD)
	  GAMMAD = ONE
	  IF (ARG .GE. ELIMIT) GAMMAD = ONE - EXP(ARG)
	END IF
C
	RETURN
	END

c This file includes the Applied Statistics algorithm AS 66 for calculating
c the tail area under the normal curve, and two alternative routines which
c give higher accuracy.   The latter have been contributed by Alan Miller of
c CSIRO Division of Mathematics & Statistics, Clayton, Victoria.   Notice
c that each function or routine has different call arguments.
c
c
      double precision function alnorm(x,upper)
c
c         Algorithm AS66 Applied Statistics (1973) vol22 no.3
c
c       Evaluates the tail area of the standardised normal curve
c       from x to infinity if upper is .true. or
c       from minus infinity to x if upper is .false.
c
      double precision zero,one,half
      double precision con,z,y,x
      double precision p,q,r,a1,a2,a3,b1,b2,c1,c2,c3,c4,c5,c6
      double precision d1,d2,d3,d4,d5
      logical upper,up
c*** machine dependent constants
      double precision ltone,utzero
      data zero/0.0d0/, one/1.0d0/, half/0.5d0/
      data ltone/7.0d0/,utzero/18.66d0/
      data con/1.28d0/
      data p/0.398942280444d0/,q/0.39990348504d0/,r/0.398942280385d0/
      data a1/5.75885480458d0/,a2/2.62433121679d0/,a3/5.92885724438d0/
      data b1/-29.8213557807d0/,b2/48.6959930692d0/
      data c1/-3.8052d-8/,c2/3.98064794d-4/,c3/-0.151679116635d0/
      data c4/4.8385912808d0/,c5/0.742380924027d0/,c6/3.99019417011d0/
      data d1/1.00000615302d0/,d2/1.98615381364d0/,d3/5.29330324926d0/
      data d4/-15.1508972451d0/,d5/30.789933034d0/
c
      up=upper
      z=x
      if(z.ge.zero)goto 10
      up=.not.up
      z=-z
   10 if(z.le.ltone.or.up.and.z.le.utzero)goto 20
      alnorm=zero
      goto 40
   20 y=half*z*z
      if(z.gt.con) goto 30
c
      alnorm=half-z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
      goto 40
   30 alnorm=r*dexp(-y)/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/
     2   (z+c6))))))
   40 if(.not.up)alnorm=one-alnorm
      return
      end
c
c
c
        SUBROUTINE NORMP(Z, P, Q, PDF)
C
C       Normal distribution probabilities accurate to 1.e-15.
C       Z = no. of standard deviations from the mean.
C       P, Q = probabilities to the left & right of Z.   P + Q = 1.
C       PDF = the probability density.
C
C       Based upon algorithm 5666 for the error function, from:
C       Hart, J.F. et al, 'Computer Approximations', Wiley 1968
C
C       Programmer: Alan Miller
C
C       Latest revision - 30 March 1986
C
        IMPLICIT DOUBLE PRECISION (A-H, O-Z)
        DATA P0, P1, P2, P3, P4, P5, P6/220.20 68679 12376 1D0,
     *    221.21 35961 69931 1D0, 112.07 92914 97870 9D0,
     *    33.912 86607 83830 0D0, 6.3739 62203 53165 0D0,
     *    .70038 30644 43688 1D0, .35262 49659 98910 9D-01/,
     *    Q0, Q1, Q2, Q3, Q4, Q5, Q6, Q7/440.41 37358 24752 2D0,
     *    793.82 65125 19948 4D0, 637.33 36333 78831 1D0,
     *    296.56 42487 79673 7D0, 86.780 73220 29460 8D0,
     *    16.064 17757 92069 5D0, 1.7556 67163 18264 2D0,
     *    .88388 34764 83184 4D-1/,
     *    CUTOFF/7.071D0/, ROOT2PI/2.5066 28274 63100 1D0/
C
        ZABS = ABS(Z)
C
C       |Z| > 37.
C
        IF (ZABS .GT. 37.D0) THEN
          PDF = 0.D0
          IF (Z .GT. 0.D0) THEN
            P = 1.D0
            Q = 0.D0
          ELSE
            P = 0.D0
            Q = 1.D0
          END IF
          RETURN
        END IF
C
C       |Z| <= 37.
C
        EXPNTL = EXP(-0.5D0*ZABS**2)
        PDF = EXPNTL/ROOT2PI
C
C       |Z| < CUTOFF = 10/sqrt(2).
C
        IF (ZABS .LT. CUTOFF) THEN
          P = EXPNTL*((((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS +
     *          P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS +
     *          Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS +
     *          Q0)
C
C       |Z| >= CUTOFF.
C
        ELSE
          P = PDF/(ZABS + 1.D0/(ZABS + 2.D0/(ZABS + 3.D0/(ZABS + 4.D0/
     *          (ZABS + 0.65D0)))))
        END IF
C
        IF (Z .LT. 0.D0) THEN
          Q = 1.D0 - P
        ELSE
          Q = P
          P = 1.D0 - Q
        END IF
        RETURN
        END
c
c
c
        SUBROUTINE NPROB(Z,P,Q,PDF)
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C       P, Q = PROBABILITIES TO THE LEFT AND RIGHT OF Z
C       FOR THE STANDARD NORMAL DISTRIBUTION.
C       PDF  = THE PROBABILITY DENSITY FUNCTION
C
C       REFERENCE: ADAMS,A.G. AREAS UNDER THE NORMAL CURVE,
C       ALGORITHM 39, COMPUTER J., VOL. 12, 197-8, 1969.
C
C       LATEST REVISION - 23 JANUARY 1981
C
C********************************************************************
C
        DATA A0,A1,A2,A3,A4,A5,A6,A7/0.5D0, 0.398942280444D0,
     1  0.399903438504D0, 5.75885480458D0, 29.8213557808D0,
     2  2.62433121679D0, 48.6959930692D0, 5.92885724438D0/,
     3  B0,B1,B2,B3,B4,B5,B6,B7,B8,B9,B10,B11/0.398942280385D0,
     4  3.8052D-8, 1.00000615302D0, 3.98064794D-4, 1.98615381364D0,
     5  0.151679116635D0, 5.29330324926D0, 4.8385912808D0,
     6  15.1508972451D0, 0.742380924027D0, 30.789933034D0,
     7  3.99019417011D0/
C
        ZABS = ABS(Z)
        IF(ZABS.GT.12.7D0) GO TO 20
        Y = A0*Z*Z
        PDF = EXP(-Y)*B0
        IF(ZABS.GT.1.28D0) GO TO 10
C
C       Z BETWEEN -1.28 AND +1.28
C
        Q = A0-ZABS*(A1-A2*Y/(Y+A3-A4/(Y+A5+A6/(Y+A7))))
        IF(Z.LT.0.D0) GO TO 30
        P = 1.D0-Q
        RETURN
C
C       ZABS BETWEEN 1.28 AND 12.7
C
   10   Q = PDF/(ZABS-B1+B2/(ZABS+B3+B4/(ZABS-B5+B6/(ZABS+B7-B8/
     1  (ZABS+B9+B10/(ZABS+B11))))))
        IF(Z.LT.0.D0) GO TO 30
        P = 1.D0-Q
        RETURN
C
C       Z FAR OUT IN TAIL
C
   20   Q = 0.D0
        PDF = 0.D0
        IF(Z.LT.0.D0) GO TO 30
        P = 1.D0
        RETURN
C
C       NEGATIVE Z, INTERCHANGE P AND Q
C
   30   P = Q
        Q = 1.D0-P
        RETURN
        END


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_EQP_EXAMPLE
   USE GALAHAD_EQP_double         ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   TYPE ( QPT_problem_type ) :: p
   TYPE ( EQP_data_type ) :: data
   TYPE ( EQP_control_type ) :: control
   TYPE ( EQP_inform_type ) :: info
   INTEGER :: s
   INTEGER, PARAMETER :: n = 3, m = 2, h_ne = 4, a_ne = 4
! start problem data
   ALLOCATE( p%G( n ), p%C( m ), p%X( n ), p%Y( m ) )
   p%new_problem_structure = .TRUE.           ! new structure
   p%n = n ; p%m = m ; p%f = 1.0_wp           ! dimensions & objective constant
   p%G = (/ 0.0_wp, 2.0_wp, 0.0_wp /)         ! objective gradient
   p%C = (/ - 2.0_wp, - 2.0_wp /)             ! constraint constants
   p%X = 0.0_wp ; p%Y = 0.0_wp                ! start from zero
! sparse co-ordinate storage format
   CALL SMT_put( p%H%type, 'COORDINATE', s )  ! Specify co-ordinate
   CALL SMT_put( p%A%type, 'COORDINATE', s )  ! storage for H and A
   ALLOCATE( p%H%val( h_ne ), p%H%row( h_ne ), p%H%col( h_ne ) )
   ALLOCATE( p%A%val( a_ne ), p%A%row( a_ne ), p%A%col( a_ne ) )
   p%H%val = (/ 1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp /) ! Hessian H
   p%H%row = (/ 1, 2, 3, 3 /)                     ! NB lower triangle
   p%H%col = (/ 1, 2, 3, 1 /) ; p%H%ne = h_ne
   p%A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /) ! Jacobian A
   p%A%row = (/ 1, 1, 2, 2 /)
   p%A%col = (/ 1, 2, 2, 3 /) ; p%A%ne = a_ne
! problem data complete
   CALL EQP_initialize( data, control )       !  Initialize control parameters
   CALL EQP_solve( p, data, control, info )   !  Solve problem
   IF ( info%status == 0 ) THEN               !  Successful return
     WRITE( 6, "( ' EQP: ', I0, ' CG iteration(s). Optimal objective value =', &
    &       ES12.4, /, ' Optimal solution = ', ( 5ES12.4 ) )" )                &
     info%cg_iter, info%obj, p%X
   ELSE                                       !  Error returns
     WRITE( 6, "( ' EQP_solve exit status = ', I6 ) " ) info%status
   END IF
   CALL EQP_terminate( data, control, info )  !  delete internal workspace
   DEALLOCATE( p%G, p%C, p%X, p%Y )           !  deallocate problem arrays
   DEALLOCATE( p%H%val, p%H%row, p%H%col, p%A%val, p%A%row, p%A%col )
   DEALLOCATE( p%H%type, p%A%type )
   END PROGRAM GALAHAD_EQP_EXAMPLE


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_orthfact_2x2diagblock
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes either the top or bottom 2x2 diagonal block
! of an orthogonal upper-hessenberg matrix that is stored as a product
! of givens rotations and a diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  TOP             LOGICAL
!                    .TRUE.: top block is computed
!                    .FALSE.: bottom block is computed
!
!  Q               REAL(8) array of dimension (4)
!                    array of generators for givens rotations
!                    generators must be orthogonal to working precision
!
!  D               REAL(8) array of dimension (2)
!                    array of generators for diagonal matrix
!                    entries must be +/-1
!
! OUTPUT VARIABLES:
!
!  H               REAL(8) array of dimension (2,2)
!                    on exit contains the desired 2x2 block
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_orthfact_2x2diagblock(TOP,Q,D,H)

  implicit none

  ! input variables
  logical, intent(in) :: TOP
  real(8), intent(in) :: Q(4), D(2)
  real(8), intent(inout) :: H(2,2)

  ! TOP == .TRUE.
  if (TOP) then

    ! initialize H
    H(1,1) = Q(1)*D(1)
    H(2,1) = Q(2)*D(1)
    H(1,2) = -Q(2)*Q(3)*D(2)
    H(2,2) = Q(1)*Q(3)*D(2)

  ! TOP == .FALSE.
  else

    ! initialize H
    H(1,1) = Q(3)*Q(1)*D(1)
    H(2,1) = Q(4)*D(1)
    H(1,2) = -Q(4)*Q(1)*D(2)
    H(2,2) = Q(3)*D(2)

  end if

end subroutine d_orthfact_2x2diagblock


MODULE nonneg_leastsq

CONTAINS

!     SUBROUTINE nnls(a, m, n, b, x, rnorm, w, indx, mode)
!
!  Algorithm NNLS: NONNEGATIVE LEAST SQUARES
!
!  The original version of this code was developed by
!  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
!  1973 JUN 15, and published in the book
!  "SOLVING LEAST SQUARES PROBLEMS", Prentice-Hall, 1974.
!  Revised FEB 1995 to accompany reprinting of the book by SIAM.
!
!  This translation into Fortran 90 by Alan Miller, February 1997
!  Latest revision - 10 June 1997

!  N.B. The following call arguments have been removed:
!       mda, zz
!
!  GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B,  COMPUTE AN
!  N-VECTOR, X, THAT SOLVES THE LEAST SQUARES PROBLEM
!
!                   A * X = B  SUBJECT TO X  >=  0
!  ------------------------------------------------------------------
!                  Subroutine Arguments
!
!  A(), M, N   ON ENTRY, A() CONTAINS THE M BY N MATRIX, A.
!              ON EXIT, A() CONTAINS THE PRODUCT MATRIX, Q*A , WHERE Q IS AN
!              M x M ORTHOGONAL MATRIX GENERATED IMPLICITLY BY THIS SUBROUTINE.
!  B()     ON ENTRY B() CONTAINS THE M-VECTOR, B.   ON EXIT B() CONTAINS Q*B.
!  X()     ON ENTRY X() NEED NOT BE INITIALIZED.
!          ON EXIT X() WILL CONTAIN THE SOLUTION VECTOR.
!  RNORM   ON EXIT RNORM CONTAINS THE EUCLIDEAN NORM OF THE RESIDUAL VECTOR.
!  W()     AN N-ARRAY OF WORKING SPACE.  ON EXIT W() WILL CONTAIN THE DUAL
!          SOLUTION VECTOR.   W WILL SATISFY W(I) = 0. FOR ALL I IN SET P
!          AND W(I) <= 0. FOR ALL I IN SET Z
!  INDX()  AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N.
!          ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS P AND Z
!          AS FOLLOWS..
!              INDX(1)   THRU INDX(NSETP) = SET P.
!              INDX(IZ1) THRU INDX(IZ2)   = SET Z.
!              IZ1 = NSETP + 1 = NPP1
!              IZ2 = N
!  MODE    THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING MEANINGS.
!          1   THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY.
!          2   THE DIMENSIONS OF THE PROBLEM ARE BAD.
!              EITHER M <= 0 OR N <= 0.
!          3   ITERATION COUNT EXCEEDED.  MORE THAN 3*N ITERATIONS.
!
!  ------------------------------------------------------------------
SUBROUTINE nnls (a, m, n, b, x, rnorm, w, indx, mode)
!     ------------------------------------------------------------------
USE constants_nswc
IMPLICIT NONE
INTEGER, INTENT(IN)       :: m, n
INTEGER, INTENT(OUT)      :: indx(:), mode
REAL (dp), INTENT(IN OUT) :: a(:,:), b(:)
REAL (dp), INTENT(OUT)    :: x(:), rnorm, w(:)

! Local variables

INTEGER                 :: i, ii, ip, iter, itmax, iz, iz1, iz2, izmax,   &
                           j, jj, jz, l, mda, npp1, nsetp
REAL (dp), DIMENSION(m) :: zz
REAL (dp), DIMENSION(1) :: dummy
REAL (dp)               :: alpha, asave, cc, factor = 0.01_dp, sm, &
                           ss, t, temp, two = 2.0_dp, unorm, up, wmax,    &
                           zero = 0.0_dp, ztest
!     ------------------------------------------------------------------
mode = 1
IF (m <= 0 .OR. n <= 0) THEN
  mode = 2
  RETURN
END IF
iter = 0
itmax = 3*n

!                    INITIALIZE THE ARRAYS indx() AND X().

DO i = 1,n
  x(i) = zero
  indx(i) = i
END DO

iz2 = n
iz1 = 1
nsetp = 0
npp1 = 1
!                             ******  MAIN LOOP BEGINS HERE  ******
!                  QUIT IF ALL COEFFICIENTS ARE ALREADY IN THE SOLUTION.
!                        OR IF M COLS OF A HAVE BEEN TRIANGULARIZED.

30 IF (iz1 > iz2 .OR. nsetp >= m) GO TO 350

!         COMPUTE COMPONENTS OF THE DUAL (NEGATIVE GRADIENT) VECTOR W().

DO iz = iz1,iz2
  j = indx(iz)
  w(j) = DOT_PRODUCT(a(npp1:m,j), b(npp1:m))
END DO

!                                   FIND LARGEST POSITIVE W(J).
60 wmax = zero
DO iz = iz1,iz2
  j = indx(iz)
  IF (w(j) > wmax) THEN
    wmax = w(j)
    izmax = iz
  END IF
END DO

!             IF WMAX  <=  0. GO TO TERMINATION.
!             THIS INDICATES SATISFACTION OF THE KUHN-TUCKER CONDITIONS.

IF (wmax <= zero) GO TO 350
iz = izmax
j = indx(iz)

!     THE SIGN OF W(J) IS OK FOR J TO BE MOVED TO SET P.
!     BEGIN THE TRANSFORMATION AND CHECK NEW DIAGONAL ELEMENT TO AVOID
!     NEAR LINEAR DEPENDENCE.

asave = a(npp1,j)
CALL h12 (1, npp1, npp1+1, m, a(:,j), up, dummy, 1, 1, 0)
unorm = zero
IF (nsetp  /=  0) THEN
  unorm = SUM( a(1:nsetp,j)**2 )
END IF
unorm = SQRT(unorm)
IF (unorm + ABS(a(npp1,j))*factor - unorm  >  zero) THEN

!        COL J IS SUFFICIENTLY INDEPENDENT.  COPY B INTO ZZ, UPDATE ZZ
!        AND SOLVE FOR ZTEST ( = PROPOSED NEW VALUE FOR X(J) ).

  zz(1:m) = b(1:m)
  CALL h12 (2, npp1, npp1+1, m, a(:,j), up, zz, 1, 1, 1)
  ztest = zz(npp1)/a(npp1,j)

!                                     SEE IF ZTEST IS POSITIVE

  IF (ztest > zero) GO TO 140
END IF

!     REJECT J AS A CANDIDATE TO BE MOVED FROM SET Z TO SET P.
!     RESTORE A(NPP1,J), SET W(J) = 0., AND LOOP BACK TO TEST DUAL
!     COEFFS AGAIN.

a(npp1,j) = asave
w(j) = zero
GO TO 60

!     THE INDEX  J = indx(IZ)  HAS BEEN SELECTED TO BE MOVED FROM
!     SET Z TO SET P.    UPDATE B,  UPDATE INDICES,  APPLY HOUSEHOLDER
!     TRANSFORMATIONS TO COLS IN NEW SET Z,  ZERO SUBDIAGONAL ELTS IN
!     COL J,  SET W(J) = 0.

140 b(1:m) = zz(1:m)

indx(iz) = indx(iz1)
indx(iz1) = j
iz1 = iz1+1
nsetp = npp1
npp1 = npp1+1

mda = SIZE(a,1)
IF (iz1  <=  iz2) THEN
  DO jz = iz1,iz2
    jj = indx(jz)
    CALL h12 (2, nsetp, npp1, m, a(:,j), up, a(:,jj), 1, mda, 1)
  END DO
END IF

IF (nsetp /= m) THEN
  a(npp1:m,j) = zero
END IF

w(j) = zero
!                                SOLVE THE TRIANGULAR SYSTEM.
!                                STORE THE SOLUTION TEMPORARILY IN ZZ().
CALL solve_triangular(zz, a, nsetp, indx)

!                       ******  SECONDARY LOOP BEGINS HERE ******

!                          ITERATION COUNTER.

210 iter = iter+1
IF (iter > itmax) THEN
  mode = 3
  WRITE (*,'(/a)') ' NNLS quitting on iteration count.'
  GO TO 350
END IF

!                    SEE IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE.
!                                  IF NOT COMPUTE ALPHA.

alpha = two
DO ip = 1,nsetp
  l = indx(ip)
  IF (zz(ip)  <=  zero) THEN
    t = -x(l)/(zz(ip)-x(l))
    IF (alpha > t) THEN
      alpha = t
      jj = ip
    END IF
  END IF
END DO

!          IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE THEN ALPHA WILL
!          STILL = 2.    IF SO EXIT FROM SECONDARY LOOP TO MAIN LOOP.

IF (alpha == two) GO TO 330

!          OTHERWISE USE ALPHA WHICH WILL BE BETWEEN 0. AND 1. TO
!          INTERPOLATE BETWEEN THE OLD X AND THE NEW ZZ.

DO ip = 1,nsetp
  l = indx(ip)
  x(l) = x(l) + alpha*(zz(ip)-x(l))
END DO

!        MODIFY A AND B AND THE INDEX ARRAYS TO MOVE COEFFICIENT I
!        FROM SET P TO SET Z.

i = indx(jj)
260 x(i) = zero

IF (jj /= nsetp) THEN
  jj = jj+1
  DO j = jj,nsetp
    ii = indx(j)
    indx(j-1) = ii
    CALL g1 (a(j-1,ii), a(j,ii), cc, ss, a(j-1,ii))
    a(j,ii) = zero
    DO l = 1,n
      IF (l /= ii) THEN

!                 Apply procedure G2 (CC,SS,A(J-1,L),A(J,L))

        temp = a(j-1,l)
        a(j-1,l) = cc*temp + ss*a(j,l)
        a(j,l)   = -ss*temp + cc*a(j,l)
      END IF
    END DO

!                 Apply procedure G2 (CC,SS,B(J-1),B(J))

    temp = b(j-1)
    b(j-1) = cc*temp + ss*b(j)
    b(j)   = -ss*temp + cc*b(j)
  END DO
END IF

npp1 = nsetp
nsetp = nsetp-1
iz1 = iz1-1
indx(iz1) = i

!        SEE IF THE REMAINING COEFFS IN SET P ARE FEASIBLE.  THEY SHOULD
!        BE BECAUSE OF THE WAY ALPHA WAS DETERMINED.
!        IF ANY ARE INFEASIBLE IT IS DUE TO ROUND-OFF ERROR.  ANY
!        THAT ARE NONPOSITIVE WILL BE SET TO ZERO
!        AND MOVED FROM SET P TO SET Z.

DO jj = 1,nsetp
  i = indx(jj)
  IF (x(i) <= zero) GO TO 260
END DO

!         COPY B( ) INTO ZZ( ).  THEN SOLVE AGAIN AND LOOP BACK.

zz(1:m) = b(1:m)
CALL solve_triangular(zz, a, nsetp, indx)
GO TO 210
!                      ******  END OF SECONDARY LOOP  ******

330 DO ip = 1,nsetp
  i = indx(ip)
  x(i) = zz(ip)
END DO
!        ALL NEW COEFFS ARE POSITIVE.  LOOP BACK TO BEGINNING.
GO TO 30

!                        ******  END OF MAIN LOOP  ******

!                        COME TO HERE FOR TERMINATION.
!                     COMPUTE THE NORM OF THE FINAL RESIDUAL VECTOR.

350 sm = zero
IF (npp1 <= m) THEN
  sm = SUM( b(npp1:m)**2 )
ELSE
  w(1:n) = zero
END IF
rnorm = SQRT(sm)
RETURN
END SUBROUTINE nnls

SUBROUTINE solve_triangular(zz, a, nsetp, indx)

!     THE FOLLOWING BLOCK OF CODE WAS USED AS AN INTERNAL SUBROUTINE
!     TO SOLVE THE TRIANGULAR SYSTEM, PUTTING THE SOLUTION IN ZZ().

USE constants_nswc
IMPLICIT NONE
REAL (dp), INTENT(IN OUT) :: zz(:)
REAL (dp), INTENT(IN)     :: a(:,:)
INTEGER, INTENT(IN)       :: nsetp, indx(:)

! Local variables
INTEGER :: l, ip, jj

DO l = 1, nsetp
  ip = nsetp+1-l
  IF (l  /=  1) zz(1:ip) = zz(1:ip) - a(1:ip,jj)*zz(ip+1)
  jj = indx(ip)
  zz(ip) = zz(ip) / a(ip,jj)
END DO

RETURN
END SUBROUTINE solve_triangular

SUBROUTINE g1(a, b, cterm, sterm, sig)

!     COMPUTE ORTHOGONAL ROTATION MATRIX..

!  The original version of this code was developed by
!  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
!  1973 JUN 12, and published in the book
!  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
!  Revised FEB 1995 to accompany reprinting of the book by SIAM.

!     COMPUTE.. MATRIX   (C, S) SO THAT (C, S)(A) = (SQRT(A**2+B**2))
!                        (-S,C)         (-S,C)(B)   (   0          )
!     COMPUTE SIG = SQRT(A**2+B**2)
!        SIG IS COMPUTED LAST TO ALLOW FOR THE POSSIBILITY THAT
!        SIG MAY BE IN THE SAME LOCATION AS A OR B .
!     ------------------------------------------------------------------
USE constants_nswc
IMPLICIT NONE
REAL (dp), INTENT(IN)  :: a, b
REAL (dp), INTENT(OUT) :: cterm, sterm, sig

!     Local variables
REAL (dp) :: one = 1.0D0, xr, yr, zero = 0.0D0
!     ------------------------------------------------------------------
IF (ABS(a) > ABS(b)) THEN
  xr = b / a
  yr = SQRT(one + xr**2)
  cterm = SIGN(one/yr, a)
  sterm = cterm * xr
  sig = ABS(a) * yr
  RETURN
END IF

IF (b /= zero) THEN
  xr = a / b
  yr = SQRT(one + xr**2)
  sterm = SIGN(one/yr, b)
  cterm = sterm * xr
  sig = ABS(b) * yr
  RETURN
END IF

!      SIG = ZERO
cterm = zero
sterm = one
RETURN
END SUBROUTINE g1

!     SUBROUTINE h12 (mode, lpivot, l1, m, u, up, c, ice, icv, ncv)

!  CONSTRUCTION AND/OR APPLICATION OF A SINGLE
!  HOUSEHOLDER TRANSFORMATION..     Q = I + U*(U**T)/B

!  The original version of this code was developed by
!  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
!  1973 JUN 12, and published in the book
!  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
!  Revised FEB 1995 to accompany reprinting of the book by SIAM.
!     ------------------------------------------------------------------
!                     Subroutine Arguments

!     MODE   = 1 OR 2   Selects Algorithm H1 to construct and apply a
!            Householder transformation, or Algorithm H2 to apply a
!            previously constructed transformation.
!     LPIVOT IS THE INDEX OF THE PIVOT ELEMENT.
!     L1,M   IF L1  <=  M   THE TRANSFORMATION WILL BE CONSTRUCTED TO
!            ZERO ELEMENTS INDEXED FROM L1 THROUGH M.   IF L1 GT. M
!            THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
!     U(),IUE,UP    On entry with MODE = 1, U() contains the pivot
!            vector.  IUE is the storage increment between elements.
!            On exit when MODE = 1, U() and UP contain quantities
!            defining the vector U of the Householder transformation.
!            on entry with MODE = 2, U() and UP should contain
!            quantities previously computed with MODE = 1.  These will
!            not be modified during the entry with MODE = 2.
!     C()    ON ENTRY with MODE = 1 or 2, C() CONTAINS A MATRIX WHICH
!            WILL BE REGARDED AS A SET OF VECTORS TO WHICH THE
!            HOUSEHOLDER TRANSFORMATION IS TO BE APPLIED.
!            ON EXIT C() CONTAINS THE SET OF TRANSFORMED VECTORS.
!     ICE    STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C().
!     ICV    STORAGE INCREMENT BETWEEN VECTORS IN C().
!     NCV    NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV  <=  0
!            NO OPERATIONS WILL BE DONE ON C().
!     ------------------------------------------------------------------
SUBROUTINE h12(mode, lpivot, l1, m, u, up, c, ice, icv, ncv)
!     ------------------------------------------------------------------

USE constants_nswc
IMPLICIT NONE
INTEGER, INTENT(IN)                     :: mode, lpivot, l1, m, ice, icv, ncv
REAL (dp), DIMENSION(:), INTENT(IN OUT) :: u, c
REAL (dp), INTENT(IN OUT)               :: up

!  Local variables
INTEGER          :: i, i2, i3, i4, incr, j
REAL (dp)        :: b, cl, clinv, one = 1.0D0, sm
!     ------------------------------------------------------------------
IF (0 >= lpivot .OR. lpivot >= l1 .OR. l1 > m) RETURN
cl = ABS(u(lpivot))
IF (mode /= 2) THEN
!                            ****** CONSTRUCT THE TRANSFORMATION. ******
  DO j = l1, m
    cl = MAX(ABS(u(j)),cl)
  END DO
  IF (cl <= 0) RETURN
  clinv = one / cl
  sm = (u(lpivot)*clinv) ** 2 + SUM( (u(l1:m)*clinv)**2 )
  cl = cl * SQRT(sm)
  IF (u(lpivot) > 0) THEN
    cl = -cl
  END IF
  up = u(lpivot) - cl
  u(lpivot) = cl
ELSE
!            ****** APPLY THE TRANSFORMATION  I+U*(U**T)/B  TO C. ******

  IF (cl <= 0) RETURN
END IF
IF (ncv <= 0) RETURN

b = up * u(lpivot)
!                       B  MUST BE NONPOSITIVE HERE.  IF B = 0., RETURN.

IF (b < 0) THEN
  b = one / b
  i2 = 1 - icv + ice * (lpivot-1)
  incr = ice * (l1-lpivot)
  DO j = 1, ncv
    i2 = i2 + icv
    i3 = i2 + incr
    i4 = i3
    sm = c(i2) * up
    DO i = l1, m
      sm = sm + c(i3) * u(i)
      i3 = i3 + ice
    END DO
    IF (sm /= 0) THEN
      sm = sm * b
      c(i2) = c(i2) + sm * up
      DO i = l1, m
        c(i4) = c(i4) + sm * u(i)
        i4 = i4 + ice
      END DO
    END IF
  END DO ! j = 1, ncv
END IF

RETURN
END SUBROUTINE h12

END MODULE nonneg_leastsq