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


PROGRAM LA_SGGEVX_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_GGEVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: BALANC
      INTEGER :: I, INFO, N, ILO, IHI
      REAL(WP) :: ABNRM, BBNRM
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:)
   REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), VL(:,:), &
     &  VR(:,:), ALPHAR(:), ALPHAI(:), BETA(:), DUMMY(:,:)
      REAL(WP), ALLOCATABLE :: RCONDE(:), RCONDV(:), LSCALE(:), RSCALE(:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'SGGEVX ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N
   PRINT *, 'N = ', N
   ALLOCATE ( A(N,N), AA(N,N), ALPHAR(N), ALPHAI(N), BETA(N), &
     &  VL(N,N), VR(N,N), B(N,N), BB(N,N) )
      ALLOCATE(RCONDE(N), RCONDV(N), LSCALE(N), RSCALE(N))
!
   READ (NIN, *) AA, BB
   A=AA; B=BB
   WRITE(NOUT,*) 'The matrix A:'
   DO I = 1, N; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,:); ENDDO
   WRITE(NOUT,*) 'The matrix B:'
   DO I = 1, N; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) B(I,:); ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_SGGEVX LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   BALANC = 'N'
   WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC=N, ILO, IHI, &
     &  LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   WRITE(NOUT,*) ' Alphar:'
   WRITE(NOUT,FMT) ALPHAR
   WRITE(NOUT,*) ' Alphai:'
   WRITE(NOUT,FMT) ALPHAI
   WRITE(NOUT,*) ' Beta:'
   WRITE(NOUT,FMT) BETA
   WRITE(NOUT,*) 'VL:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VL(:,I); END DO
   WRITE(NOUT,*) 'VR:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VR(:,I); END DO
   WRITE(NOUT,*) 'ILO = ', ILO; WRITE(NOUT,*) 'IHI = ', IHI
   WRITE (NOUT,*) 'ABNRM = ', ABNRM;  WRITE (NOUT,*) 'BBNRM = ', BBNRM
   WRITE(NOUT,*) ' LSCALE :'; WRITE(NOUT,FMT) LSCALE
      WRITE(NOUT,*) ' RSCALE :'; WRITE(NOUT,FMT) RSCALE
      WRITE(NOUT,*) ' RCONDE :'; WRITE(NOUT,FMT) RCONDE
      WRITE(NOUT,*) ' RCONDV :'; WRITE(NOUT,FMT) RCONDV
!
   BALANC = 'P'
   WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC=P, ILO, IHI, &
     &  LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   WRITE(NOUT,*) ' Alphar:'
   WRITE(NOUT,FMT) ALPHAR
   WRITE(NOUT,*) ' Alphai:'
   WRITE(NOUT,FMT) ALPHAI
   WRITE(NOUT,*) ' Beta:'
   WRITE(NOUT,FMT) BETA
   WRITE(NOUT,*) 'VL:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VL(:,I); END DO
   WRITE(NOUT,*) 'VR:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VR(:,I); END DO
   WRITE(NOUT,*) 'ILO = ', ILO; WRITE(NOUT,*) 'IHI = ', IHI
   WRITE (NOUT,*) 'ABNRM = ', ABNRM;  WRITE (NOUT,*) 'BBNRM = ', BBNRM
   WRITE(NOUT,*) ' LSCALE :'; WRITE(NOUT,FMT) LSCALE
      WRITE(NOUT,*) ' RSCALE :'; WRITE(NOUT,FMT) RSCALE
      WRITE(NOUT,*) ' RCONDE :'; WRITE(NOUT,FMT) RCONDE
      WRITE(NOUT,*) ' RCONDV :'; WRITE(NOUT,FMT) RCONDV
!
   BALANC = 'S'
   WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC=S, ILO, IHI, &
     &  LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   WRITE(NOUT,*) ' Alphar:'
   WRITE(NOUT,FMT) ALPHAR
   WRITE(NOUT,*) ' Alphai:'
   WRITE(NOUT,FMT) ALPHAI
   WRITE(NOUT,*) ' Beta:'
   WRITE(NOUT,FMT) BETA
   WRITE(NOUT,*) 'VL:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VL(:,I); END DO
   WRITE(NOUT,*) 'VR:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VR(:,I); END DO
   WRITE(NOUT,*) 'ILO = ', ILO; WRITE(NOUT,*) 'IHI = ', IHI
   WRITE (NOUT,*) 'ABNRM = ', ABNRM;  WRITE (NOUT,*) 'BBNRM = ', BBNRM
   WRITE(NOUT,*) ' LSCALE :'; WRITE(NOUT,FMT) LSCALE
      WRITE(NOUT,*) ' RSCALE :'; WRITE(NOUT,FMT) RSCALE
      WRITE(NOUT,*) ' RCONDE :'; WRITE(NOUT,FMT) RCONDE
      WRITE(NOUT,*) ' RCONDV :'; WRITE(NOUT,FMT) RCONDV
!
   BALANC = 'B'
   WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR,BALANC=B,&
     &  ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   WRITE(NOUT,*) ' Alphar:'
   WRITE(NOUT,FMT) ALPHAR
   WRITE(NOUT,*) ' Alphai:'
   WRITE(NOUT,FMT) ALPHAI
   WRITE(NOUT,*) ' Beta:'
   WRITE(NOUT,FMT) BETA
   WRITE(NOUT,*) 'VL:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VL(:,I); END DO
   WRITE(NOUT,*) 'VR:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VR(:,I); END DO
   WRITE(NOUT,*) 'ILO = ', ILO; WRITE(NOUT,*) 'IHI = ', IHI
   WRITE (NOUT,*) 'ABNRM = ', ABNRM;  WRITE (NOUT,*) 'BBNRM = ', BBNRM
   WRITE(NOUT,*) ' LSCALE :'; WRITE(NOUT,FMT) LSCALE
      WRITE(NOUT,*) ' RSCALE :'; WRITE(NOUT,FMT) RSCALE
      WRITE(NOUT,*) ' RCONDE :'; WRITE(NOUT,FMT) RCONDE
      WRITE(NOUT,*) ' RCONDV :'; WRITE(NOUT,FMT) RCONDV
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, INFO=INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   WRITE(NOUT,*) 'A:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(:,I); END DO
   WRITE(NOUT,*) 'B:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) B(:,I); END DO
   WRITE(NOUT,*) ' Alphar:'
   WRITE(NOUT,FMT) ALPHAR
   WRITE(NOUT,*) ' Alphai:'
   WRITE(NOUT,FMT) ALPHAI
   WRITE(NOUT,*) ' Beta:'
   WRITE(NOUT,FMT) BETA
!STARTING THE ERROR RESULT TESTINGS
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( DUMMY, B, ALPHAR, ALPHAI, BETA, INFO=INFO )'
   A=AA
   CALL LA_GGEVX( DUMMY, B, ALPHAR, ALPHAI, BETA, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, DUMMY, ALPHAR, ALPHAI, BETA, INFO=INFO )'
   A=AA
   CALL LA_GGEVX( A, DUMMY, ALPHAR, ALPHAI, BETA, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 3
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR(1:N-1), ALPHAI, BETA, INFO=INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR(1:N-1), ALPHAI, BETA, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI(1:N-1), BETA, INFO=INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI(1:N-1), BETA, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA(1:N-1), INFO=INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA(1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 6
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL(:,1:N-1), INFO=INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL(:,1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL(1:N-1,:), INFO=INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL(1:N-1,:), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 7
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VR=VR(1:N-1,:), INFO=INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VR=VR(1:N-1,:), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VR=VR(:,1:N-1), INFO = INFO )'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VR=VR(:,1:N-1), INFO = INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 8
   BALANC = 'T'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC=T, INFO = INFO)'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC='T', INFO = INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 11
   BALANC = 'T'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC=B, LSCALE=LSCALE(1:N-1), INFO = INFO)'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC='B',  LSCALE=LSCALE(1:N-1), INFO = INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 12
   BALANC = 'T'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC=B, RSCALE=RSCALE(1:N-1), INFO = INFO)'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC='B', RSCALE=RSCALE(1 :N-1),INFO = INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 15
   BALANC = 'T'
   WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC=B, &
     &  RSCALE=RSCALE(1:N-1), RCONDE=RCONDE(1:N-1), INFO = INFO)'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC='B', RSCALE=RSCALE(1 :N-1), RCONDE=RCONDE(1:N-1), INFO = INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 16
   BALANC = 'T'
   WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC=B, RSCALE=RSCALE(1:N-1), &
     &  RCONDV=RCONDV(1:N-1), INFO = INFO)'
   A=AA
   CALL LA_GGEVX( A, B, ALPHAR, ALPHAI, BETA, VL, VR, BALANC='B', RSCALE=RSCALE(1 :N-1), RCONDV=RCONDV(1:N-1), INFO = INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
END PROGRAM LA_SGGEVX_ET_EXAMPLE


*DECK VNWRMS
      REAL FUNCTION VNWRMS (N, V, W)
C***BEGIN PROLOGUE  VNWRMS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DEBDF
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (VNWRMS-S, DVNRMS-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   VNWRMS computes a weighted root-mean-square vector norm for the
C   integrator package DEBDF.
C
C***SEE ALSO  DEBDF
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  VNWRMS
C
C
CLLL. OPTIMIZE
C-----------------------------------------------------------------------
C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM
C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS
C CONTAINED IN THE ARRAY W OF LENGTH N..
C   VNWRMS = SQRT( (1/N) * SUM( V(I)/W(I) )**2 )
C-----------------------------------------------------------------------
      INTEGER N, I
      REAL V, W, SUM
      DIMENSION V(*), W(*)
C***FIRST EXECUTABLE STATEMENT  VNWRMS
      SUM = 0.0E0
      DO 10 I = 1,N
 10     SUM = SUM + (V(I)/W(I))**2
      VNWRMS = SQRT(SUM/N)
      RETURN
C----------------------- END OF FUNCTION VNWRMS ------------------------
      END


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine z_solve

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c this function performs the solution of the approximate factorization
c step in the z-direction for all five matrix components
c simultaneously. The Thomas algorithm is employed to solve the
c systems for the z-lines. Boundary conditions are non-periodic
c---------------------------------------------------------------------

       include 'header.h'
       include 'mpinpb.h'

       integer i, j, k, stage, ip, jp, n, isize, jsize, kend, k1, k2,
     >         buffer_size, c, m, p, kstart, error,
     >         requests(2), statuses(MPI_STATUS_SIZE, 2)
       double precision  r1, r2, d, e, s(5), sm1, sm2,
     >                   fac1, fac2

c---------------------------------------------------------------------
c now do a sweep on a layer-by-layer basis, i.e. sweeping through cells
c on this node in the direction of increasing i for the forward sweep,
c and after that reversing the direction for the backsubstitution
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c                          FORWARD ELIMINATION
c---------------------------------------------------------------------
       do    stage = 1, ncells
          c         = slice(3,stage)

          kstart = 0
          kend   = cell_size(3,c)-1

          isize     = cell_size(1,c)
          jsize     = cell_size(2,c)
          ip        = cell_coord(1,c)-1
          jp        = cell_coord(2,c)-1

          buffer_size = (isize-start(1,c)-end(1,c)) *
     >                  (jsize-start(2,c)-end(2,c))

          if (stage .ne. 1) then

c---------------------------------------------------------------------
c            if this is not the first processor in this row of cells,
c            receive data from predecessor containing the right hand
c            sides and the upper diagonal elements of the previous two rows
c---------------------------------------------------------------------

             call mpi_irecv(in_buffer, 22*buffer_size,
     >                      dp_type, predecessor(3),
     >                      DEFAULT_TAG, comm_solve,
     >                      requests(1), error)

c---------------------------------------------------------------------
c            communication has already been started.
c            compute the left hand side while waiting for the msg
c---------------------------------------------------------------------
             call lhsz(c)

c---------------------------------------------------------------------
c            wait for pending communication to complete
c---------------------------------------------------------------------
             call mpi_waitall(2, requests, statuses, error)

c---------------------------------------------------------------------
c            unpack the buffer
c---------------------------------------------------------------------
             k  = kstart
             k1 = kstart + 1
             n = 0

c---------------------------------------------------------------------
c            create a running pointer
c---------------------------------------------------------------------
             p = 0
             do    j = start(2,c), jsize-end(2,c)-1
                do    i = start(1,c), isize-end(1,c)-1
                   lhs(i,j,k,n+2,c) = lhs(i,j,k,n+2,c) -
     >                       in_buffer(p+1) * lhs(i,j,k,n+1,c)
                   lhs(i,j,k,n+3,c) = lhs(i,j,k,n+3,c) -
     >                       in_buffer(p+2) * lhs(i,j,k,n+1,c)
                   do    m = 1, 3
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                       in_buffer(p+2+m) * lhs(i,j,k,n+1,c)
                   end do
                   d            = in_buffer(p+6)
                   e            = in_buffer(p+7)
                   do    m = 1, 3
                      s(m) = in_buffer(p+7+m)
                   end do
                   r1 = lhs(i,j,k,n+2,c)
                   lhs(i,j,k,n+3,c) = lhs(i,j,k,n+3,c) - d * r1
                   lhs(i,j,k,n+4,c) = lhs(i,j,k,n+4,c) - e * r1
                   do    m = 1, 3
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) - s(m) * r1
                   end do
                   r2 = lhs(i,j,k1,n+1,c)
                   lhs(i,j,k1,n+2,c) = lhs(i,j,k1,n+2,c) - d * r2
                   lhs(i,j,k1,n+3,c) = lhs(i,j,k1,n+3,c) - e * r2
                   do    m = 1, 3
                      rhs(i,j,k1,m,c) = rhs(i,j,k1,m,c) - s(m) * r2
                   end do
                   p = p + 10
                end do
             end do

             do    m = 4, 5
                n = (m-3)*5
                do    j = start(2,c), jsize-end(2,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                      lhs(i,j,k,n+2,c) = lhs(i,j,k,n+2,c) -
     >                          in_buffer(p+1) * lhs(i,j,k,n+1,c)
                      lhs(i,j,k,n+3,c) = lhs(i,j,k,n+3,c) -
     >                          in_buffer(p+2) * lhs(i,j,k,n+1,c)
                      rhs(i,j,k,m,c)   = rhs(i,j,k,m,c) -
     >                          in_buffer(p+3) * lhs(i,j,k,n+1,c)
                      d                = in_buffer(p+4)
                      e                = in_buffer(p+5)
                      s(m)             = in_buffer(p+6)
                      r1 = lhs(i,j,k,n+2,c)
                      lhs(i,j,k,n+3,c) = lhs(i,j,k,n+3,c) - d * r1
                      lhs(i,j,k,n+4,c) = lhs(i,j,k,n+4,c) - e * r1
                      rhs(i,j,k,m,c)   = rhs(i,j,k,m,c) - s(m) * r1
                      r2 = lhs(i,j,k1,n+1,c)
                      lhs(i,j,k1,n+2,c) = lhs(i,j,k1,n+2,c) - d * r2
                      lhs(i,j,k1,n+3,c) = lhs(i,j,k1,n+3,c) - e * r2
                      rhs(i,j,k1,m,c)   = rhs(i,j,k1,m,c) - s(m) * r2
                      p = p + 6
                   end do
                end do
             end do

          else

c---------------------------------------------------------------------
c            if this IS the first cell, we still compute the lhs
c---------------------------------------------------------------------
             call lhsz(c)
          endif

c---------------------------------------------------------------------
c         perform the Thomas algorithm; first, FORWARD ELIMINATION
c---------------------------------------------------------------------
          n = 0

          do    k = kstart, kend-2
             do    j = start(2,c), jsize-end(2,c)-1
                do    i = start(1,c), isize-end(1,c)-1
                   k1 = k  + 1
                   k2 = k  + 2
                   fac1               = 1.d0/lhs(i,j,k,n+3,c)
                   lhs(i,j,k,n+4,c)   = fac1*lhs(i,j,k,n+4,c)
                   lhs(i,j,k,n+5,c)   = fac1*lhs(i,j,k,n+5,c)
                   do    m = 1, 3
                      rhs(i,j,k,m,c) = fac1*rhs(i,j,k,m,c)
                   end do
                   lhs(i,j,k1,n+3,c) = lhs(i,j,k1,n+3,c) -
     >                         lhs(i,j,k1,n+2,c)*lhs(i,j,k,n+4,c)
                   lhs(i,j,k1,n+4,c) = lhs(i,j,k1,n+4,c) -
     >                         lhs(i,j,k1,n+2,c)*lhs(i,j,k,n+5,c)
                   do    m = 1, 3
                      rhs(i,j,k1,m,c) = rhs(i,j,k1,m,c) -
     >                         lhs(i,j,k1,n+2,c)*rhs(i,j,k,m,c)
                   end do
                   lhs(i,j,k2,n+2,c) = lhs(i,j,k2,n+2,c) -
     >                         lhs(i,j,k2,n+1,c)*lhs(i,j,k,n+4,c)
                   lhs(i,j,k2,n+3,c) = lhs(i,j,k2,n+3,c) -
     >                         lhs(i,j,k2,n+1,c)*lhs(i,j,k,n+5,c)
                   do    m = 1, 3
                      rhs(i,j,k2,m,c) = rhs(i,j,k2,m,c) -
     >                         lhs(i,j,k2,n+1,c)*rhs(i,j,k,m,c)
                   end do
                end do
             end do
          end do

c---------------------------------------------------------------------
c         The last two rows in this grid block are a bit different,
c         since they do not have two more rows available for the
c         elimination of off-diagonal entries
c---------------------------------------------------------------------
          k  = kend - 1
          k1 = kend
          do    j = start(2,c), jsize-end(2,c)-1
             do    i = start(1,c), isize-end(1,c)-1
                fac1               = 1.d0/lhs(i,j,k,n+3,c)
                lhs(i,j,k,n+4,c)   = fac1*lhs(i,j,k,n+4,c)
                lhs(i,j,k,n+5,c)   = fac1*lhs(i,j,k,n+5,c)
                do    m = 1, 3
                   rhs(i,j,k,m,c) = fac1*rhs(i,j,k,m,c)
                end do
                lhs(i,j,k1,n+3,c) = lhs(i,j,k1,n+3,c) -
     >                      lhs(i,j,k1,n+2,c)*lhs(i,j,k,n+4,c)
                lhs(i,j,k1,n+4,c) = lhs(i,j,k1,n+4,c) -
     >                      lhs(i,j,k1,n+2,c)*lhs(i,j,k,n+5,c)
                do    m = 1, 3
                   rhs(i,j,k1,m,c) = rhs(i,j,k1,m,c) -
     >                      lhs(i,j,k1,n+2,c)*rhs(i,j,k,m,c)
                end do
c---------------------------------------------------------------------
c               scale the last row immediately (some of this is
c               overkill in case this is the last cell)
c---------------------------------------------------------------------
                fac2               = 1.d0/lhs(i,j,k1,n+3,c)
                lhs(i,j,k1,n+4,c) = fac2*lhs(i,j,k1,n+4,c)
                lhs(i,j,k1,n+5,c) = fac2*lhs(i,j,k1,n+5,c)
                do    m = 1, 3
                   rhs(i,j,k1,m,c) = fac2*rhs(i,j,k1,m,c)
                end do
             end do
          end do

c---------------------------------------------------------------------
c         do the u+c and the u-c factors
c---------------------------------------------------------------------
          do   m = 4, 5
             n = (m-3)*5
             do    k = kstart, kend-2
                do    j = start(2,c), jsize-end(2,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                   k1 = k  + 1
                   k2 = k  + 2
                   fac1               = 1.d0/lhs(i,j,k,n+3,c)
                   lhs(i,j,k,n+4,c)   = fac1*lhs(i,j,k,n+4,c)
                   lhs(i,j,k,n+5,c)   = fac1*lhs(i,j,k,n+5,c)
                   rhs(i,j,k,m,c) = fac1*rhs(i,j,k,m,c)
                   lhs(i,j,k1,n+3,c) = lhs(i,j,k1,n+3,c) -
     >                         lhs(i,j,k1,n+2,c)*lhs(i,j,k,n+4,c)
                   lhs(i,j,k1,n+4,c) = lhs(i,j,k1,n+4,c) -
     >                         lhs(i,j,k1,n+2,c)*lhs(i,j,k,n+5,c)
                   rhs(i,j,k1,m,c) = rhs(i,j,k1,m,c) -
     >                         lhs(i,j,k1,n+2,c)*rhs(i,j,k,m,c)
                   lhs(i,j,k2,n+2,c) = lhs(i,j,k2,n+2,c) -
     >                         lhs(i,j,k2,n+1,c)*lhs(i,j,k,n+4,c)
                   lhs(i,j,k2,n+3,c) = lhs(i,j,k2,n+3,c) -
     >                         lhs(i,j,k2,n+1,c)*lhs(i,j,k,n+5,c)
                   rhs(i,j,k2,m,c) = rhs(i,j,k2,m,c) -
     >                         lhs(i,j,k2,n+1,c)*rhs(i,j,k,m,c)
                end do
             end do
          end do

c---------------------------------------------------------------------
c            And again the last two rows separately
c---------------------------------------------------------------------
             k  = kend - 1
             k1 = kend
             do    j = start(2,c), jsize-end(2,c)-1
                do    i = start(1,c), isize-end(1,c)-1
                fac1               = 1.d0/lhs(i,j,k,n+3,c)
                lhs(i,j,k,n+4,c)   = fac1*lhs(i,j,k,n+4,c)
                lhs(i,j,k,n+5,c)   = fac1*lhs(i,j,k,n+5,c)
                rhs(i,j,k,m,c)     = fac1*rhs(i,j,k,m,c)
                lhs(i,j,k1,n+3,c) = lhs(i,j,k1,n+3,c) -
     >                      lhs(i,j,k1,n+2,c)*lhs(i,j,k,n+4,c)
                lhs(i,j,k1,n+4,c) = lhs(i,j,k1,n+4,c) -
     >                      lhs(i,j,k1,n+2,c)*lhs(i,j,k,n+5,c)
                rhs(i,j,k1,m,c)   = rhs(i,j,k1,m,c) -
     >                      lhs(i,j,k1,n+2,c)*rhs(i,j,k,m,c)
c---------------------------------------------------------------------
c               Scale the last row immediately (some of this is overkill
c               if this is the last cell)
c---------------------------------------------------------------------
                fac2               = 1.d0/lhs(i,j,k1,n+3,c)
                lhs(i,j,k1,n+4,c) = fac2*lhs(i,j,k1,n+4,c)
                lhs(i,j,k1,n+5,c) = fac2*lhs(i,j,k1,n+5,c)
                rhs(i,j,k1,m,c)   = fac2*rhs(i,j,k1,m,c)

             end do
          end do
       end do

c---------------------------------------------------------------------
c         send information to the next processor, except when this
c         is the last grid block,
c---------------------------------------------------------------------

          if (stage .ne. ncells) then

c---------------------------------------------------------------------
c            create a running pointer for the send buffer
c---------------------------------------------------------------------
             p = 0
             n = 0
             do    j = start(2,c), jsize-end(2,c)-1
                do    i = start(1,c), isize-end(1,c)-1
                   do    k = kend-1, kend
                      out_buffer(p+1) = lhs(i,j,k,n+4,c)
                      out_buffer(p+2) = lhs(i,j,k,n+5,c)
                      do    m = 1, 3
                         out_buffer(p+2+m) = rhs(i,j,k,m,c)
                      end do
                      p = p+5
                   end do
                end do
             end do

             do    m = 4, 5
                n = (m-3)*5
                do    j = start(2,c), jsize-end(2,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                      do    k = kend-1, kend
                         out_buffer(p+1) = lhs(i,j,k,n+4,c)
                         out_buffer(p+2) = lhs(i,j,k,n+5,c)
                         out_buffer(p+3) = rhs(i,j,k,m,c)
                         p = p + 3
                      end do
                   end do
                end do
             end do

             call mpi_isend(out_buffer, 22*buffer_size,
     >                     dp_type, successor(3),
     >                     DEFAULT_TAG, comm_solve,
     >                     requests(2), error)

          endif
       end do

c---------------------------------------------------------------------
c      now go in the reverse direction
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c                         BACKSUBSTITUTION
c---------------------------------------------------------------------
       do    stage = ncells, 1, -1
          c = slice(3,stage)

          kstart = 0
          kend   = cell_size(3,c)-1

          isize     = cell_size(1,c)
          jsize     = cell_size(2,c)
          ip        = cell_coord(1,c)-1
          jp        = cell_coord(2,c)-1

          buffer_size = (isize-start(1,c)-end(1,c)) *
     >                  (jsize-start(2,c)-end(2,c))

          if (stage .ne. ncells) then

c---------------------------------------------------------------------
c            if this is not the starting cell in this row of cells,
c            wait for a message to be received, containing the
c            solution of the previous two stations
c---------------------------------------------------------------------

             call mpi_irecv(in_buffer, 10*buffer_size,
     >                      dp_type, successor(3),
     >                      DEFAULT_TAG, comm_solve,
     >                      requests(1), error)

c---------------------------------------------------------------------
c            communication has already been started
c            while waiting, do the  block-diagonal inversion for the
c            cell that was just finished
c---------------------------------------------------------------------

             call tzetar(slice(3,stage+1))

c---------------------------------------------------------------------
c            wait for pending communication to complete
c---------------------------------------------------------------------
             call mpi_waitall(2, requests, statuses, error)

c---------------------------------------------------------------------
c            unpack the buffer for the first three factors
c---------------------------------------------------------------------
             n = 0
             p = 0
             k  = kend
             k1 = k - 1
             do    m = 1, 3
                do   j = start(2,c), jsize-end(2,c)-1
                   do   i = start(1,c), isize-end(1,c)-1
                      sm1 = in_buffer(p+1)
                      sm2 = in_buffer(p+2)
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                        lhs(i,j,k,n+4,c)*sm1 -
     >                        lhs(i,j,k,n+5,c)*sm2
                      rhs(i,j,k1,m,c) = rhs(i,j,k1,m,c) -
     >                        lhs(i,j,k1,n+4,c) * rhs(i,j,k,m,c) -
     >                        lhs(i,j,k1,n+5,c) * sm1
                      p = p + 2
                   end do
                end do
             end do

c---------------------------------------------------------------------
c            now unpack the buffer for the remaining two factors
c---------------------------------------------------------------------
             do    m = 4, 5
                n = (m-3)*5
                do   j = start(2,c), jsize-end(2,c)-1
                   do   i = start(1,c), isize-end(1,c)-1
                      sm1 = in_buffer(p+1)
                      sm2 = in_buffer(p+2)
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                        lhs(i,j,k,n+4,c)*sm1 -
     >                        lhs(i,j,k,n+5,c)*sm2
                      rhs(i,j,k1,m,c) = rhs(i,j,k1,m,c) -
     >                        lhs(i,j,k1,n+4,c) * rhs(i,j,k,m,c) -
     >                        lhs(i,j,k1,n+5,c) * sm1
                      p = p + 2
                   end do
                end do
             end do

          else

c---------------------------------------------------------------------
c            now we know this is the first grid block on the back sweep,
c            so we don't need a message to start the substitution.
c---------------------------------------------------------------------

             k  = kend - 1
             k1 = kend
             n = 0
             do   m = 1, 3
                do   j = start(2,c), jsize-end(2,c)-1
                   do   i = start(1,c), isize-end(1,c)-1
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                             lhs(i,j,k,n+4,c)*rhs(i,j,k1,m,c)
                   end do
                end do
             end do

             do    m = 4, 5
                n = (m-3)*5
                do   j = start(2,c), jsize-end(2,c)-1
                   do   i = start(1,c), isize-end(1,c)-1
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                             lhs(i,j,k,n+4,c)*rhs(i,j,k1,m,c)
                   end do
                end do
             end do
          endif

c---------------------------------------------------------------------
c         Whether or not this is the last processor, we always have
c         to complete the back-substitution
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c         The first three factors
c---------------------------------------------------------------------
          n = 0
          do   m = 1, 3
             do   k = kend-2, kstart, -1
                do   j = start(2,c), jsize-end(2,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                      k1 = k  + 1
                      k2 = k  + 2
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                          lhs(i,j,k,n+4,c)*rhs(i,j,k1,m,c) -
     >                          lhs(i,j,k,n+5,c)*rhs(i,j,k2,m,c)
                   end do
                end do
             end do
          end do

c---------------------------------------------------------------------
c         And the remaining two
c---------------------------------------------------------------------
          do    m = 4, 5
             n = (m-3)*5
             do   k = kend-2, kstart, -1
                do   j = start(2,c), jsize-end(2,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                      k1 = k  + 1
                      k2 = k  + 2
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                          lhs(i,j,k,n+4,c)*rhs(i,j,k1,m,c) -
     >                          lhs(i,j,k,n+5,c)*rhs(i,j,k2,m,c)
                   end do
                end do
             end do
          end do

c---------------------------------------------------------------------
c         send on information to the previous processor, if needed
c---------------------------------------------------------------------
          if (stage .ne.  1) then
             k  = kstart
             k1 = kstart + 1
             p = 0
             do    m = 1, 5
                do    j = start(2,c), jsize-end(2,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                      out_buffer(p+1) = rhs(i,j,k,m,c)
                      out_buffer(p+2) = rhs(i,j,k1,m,c)
                      p = p + 2
                   end do
                end do
             end do

             call mpi_isend(out_buffer, 10*buffer_size,
     >                     dp_type, predecessor(3),
     >                     DEFAULT_TAG, comm_solve,
     >                     requests(2), error)

          endif

c---------------------------------------------------------------------
c         If this was the last stage, do the block-diagonal inversion
c---------------------------------------------------------------------
          if (stage .eq. 1) call tzetar(c)

       end do

       return
       end


! ********** HAUPTPROGRAMM **********

program shallow_water_prog

	! benutzte Module hinzufuegen
	use vartypes
	use exp_sw_schemes
	use imp_sw_schemes
	use sw_flux

	! Implizite Deklaration ausschalten
	implicit none

	! Variablendeklaration
	integer, parameter			:: nx = 10001			! Anzahl der x-Gitterpunkte
	integer						:: animate			! =1: alle Zeitschritte schreiben, =0: nur den letzten
	real(dp)					:: rightx			! rechtes x
	integer, parameter			:: numsolv = 2		! Anzahl der Loesungsvariablen
	real(dp)					:: tfinal			! Endzeit
	real(dp)					:: time				! Fuer die Zeitschleife
	type(t_vectorBlock)			:: U, U0			! Loesungsvektoren
	real(dp), dimension(nx)		:: x				! Ortsvektor
	real(dp)					:: dx, dt			! Schrittweiten
	real(dp)					:: time0, time1		! Zur Zeitmessung
	real(dp)                    :: rcoeff
	integer						:: i,j				! Laufvariablen
	type(t_vectorBlock)			:: tmpU				! Zum Tauschen von U und U0

	! Speicher reservieren fuer U und U0
	call make_vectorBlock(U, numsolv,nx)
	call make_vectorBlock(U0,numsolv,nx)

	! Parameter initialisieren
	rightx = 10d0						! rechtes x
	dx = 1.0d0/(nx-1)*rightx			! Ortsschrittweite
	dt = 0.0001d0							! Zeitschrittweite
	tfinal = 1d0						! Endzeit
	animate = 0							! Auch Zwischenschritte animieren

	! Ortsgitter initialisieren
	forall(i=1:nx)
		x(i)=(i-1)*dx
	end forall

	! Loesungsvektor initialisieren
	! Hoehe h initialisieren
	U0%DvectorBlock(1)%datas = 1.0d0
	where (abs(x)<2.5)
		!U0%DvectorBlock(1)%datas = 1.d0+0.4*exp(-5*(x-5.0d0)**2.0d0)
		U0%DvectorBlock(1)%datas = 2.0d0
	end where
	! Geschwindigkeit u initialisieren
	U0%DvectorBlock(2)%datas = 0
	where (x>25)
		U0%DvectorBlock(2)%datas = 0.0d0
	end where

	! Dateien oeffnen
	open(10,file='out.dat')
	open(11,file='parameter.dat')
	write(11,*) nx
	close(11)

	! Ausgabe des Startvektors
	if (animate==1) then
        do i=1,nx
           write(10,FMT='(E15.6E3,1X,E15.6E3,1X,E15.6E3)') x(i),&
                U0%Dvectorblock(1)%datas(i),&
                U0%Dvectorblock(2)%datas(i)    ! x, h, hu
        end do
	end if

	! Zur Zeitberechnung
	call cpu_time(time0)

	! Loesungsschleife
	time = 0.0d0
 	timestepping: do
		time = time + dt
		if (time>tfinal) exit timestepping

        write(*,*) "Momentane Zeit:",time

		! Loeser aufrufen
		call onedswtvd(U, U0, x, dt, dx, swF, swA, swR, swRi)
		!call imp_onedswupwind(U, U0, x, dt, dx, 0.5d0, 1, swF, swA, swR, swRi)

		! Quellterm einfuegen
		do i=2,nx-1
		rcoeff = x(i)
		if (rcoeff < 1d-8) then
		    rcoeff = 0!-dt*1/1d-8
		else
		    rcoeff = -dt*1/rcoeff
		end if

            U%Dvectorblock(1)%datas(i)=U%Dvectorblock(1)%datas(i)&
               +rcoeff*U%Dvectorblock(2)%datas(i)
            U%Dvectorblock(2)%datas(i)=U%Dvectorblock(2)%datas(i)&
               +rcoeff*U%Dvectorblock(2)%datas(i)*U%Dvectorblock(2)%datas(i)&
                /U%Dvectorblock(1)%datas(i)
        end do

		! Ausgabe
		if (animate==1) then
                do i=1,nx
                   write(10,FMT='(E15.6E3,1X,E15.6E3,1X,E15.6E3)') x(i),&
                        U0%Dvectorblock(1)%datas(i),&
                        U0%Dvectorblock(2)%datas(i)    ! x, h, hu
                end do
        end if

		! U und U0 vertauschen
		tmpU = U
		U = U0
		U0 = tmpU

	end do timestepping

	! Ausgabe des Loesungsvektors
    do i=1,nx
       write(10,FMT='(E15.6E3,1X,E15.6E3,1X,E15.6E3)') x(i),&
            U0%Dvectorblock(1)%datas(i),&
            U0%Dvectorblock(2)%datas(i)    ! x, h, h*u
    end do

	! Ausgabe der benoetigten Zeit
	call cpu_time(time1)
	write(*,*) 'Benoetigte Zeit:', time1-time0,'Sekunden.'

	! Dateien schliessen
	close(10)

	! Speicher von U und U0 freigeben
	call unmake_vectorBlock(U)
	call unmake_vectorBlock(U0)

end program shallow_water_prog


PROGRAM DIIS_test

    USE DIIS
    USE OUTPUT

    IMPLICIT NONE

    REAL*8, dimension(3,3) :: A
    REAL*8, dimension(3*3) :: B
    REAL*8, dimension(3,3) :: C
    REAL*8, dimension(3,3) :: D
    REAL*8, dimension(3*3) :: E
    REAL*8, allocatable, dimension(:,:) :: F
    REAL*8 :: maxerr
    REAL*8, allocatable, dimension(:) :: w
    REAL*8, allocatable, dimension(:,:) :: Elist
    REAL*8, allocatable, dimension(:,:,:) :: Mlist

    INTEGER :: info, dim, i, j

    A(1,:) = (/1.0D0, 2.0D0, 3.0D0/)
    A(2,:) = (/4.0D0, 5.0D0, 6.0D0/)
    A(3,:) = (/7.0D0, 8.0D0, 9.0D0/)

    WRITE(*,*) "Matrix A:"
    CALL print_real_matrix(3,3,A)

    CALL ravel(3,A,B)

    WRITE(*,*)
    WRITE(*,*) "Vector B (ravel(A)):"

    CALL print_real_vector(3*3,B)

    A(1,:) = (/0.0D0, 1.0D0, 0.0D0/)
    A(2,:) = (/-1.0D0, 0.0D0, 0.0D0/)
    A(3,:) = (/0.0D0, 0.0D0, 1.0D0/)

    C(1,:) = (/1.0D0, 0.0D0, 0.0D0/)
    C(2,:) = (/0.0D0, 0.0D0, 1.0D0/)
    C(3,:) = (/0.0D0, -1.0D0, 0.0D0/)

    D(1,:) = (/1.0D0, 0.0D0, 0.0D0/)
    D(2,:) = (/0.0D0, 1.0D0, 0.0D0/)
    D(3,:) = (/0.0D0, 0.0D0, 1.0D0/)

    CALL DIIS_error(3,A,C,D,D,E,maxerr)

    WRITE(*,*)
    WRITE(*,*) "Error matrix:"

    CALL print_real_matrix(3,3,MATMUL(A,MATMUL(C,D)) - MATMUL(D,MATMUL(C,A)))

    WRITE(*,*)
    WRITE(*,*) "Error E:"

    CALL print_real_vector(3*3,E)

    WRITE(*,*)
    WRITE(*,*) "Maxerr: ", maxerr

    CALL addError(3,1,Elist,E)
    CALL addError(3,2,Elist,E)
    CALL addError(3,3,Elist,E)

    WRITE(*,*)
    WRITE(*,*) "Elist(1):"

    CALL print_real_vector(3*3,Elist(1,:))

    WRITE(*,*)
    WRITE(*,*) "Elist(2):"

    CALL print_real_vector(3*3,Elist(2,:))

    WRITE(*,*)
    WRITE(*,*) "Elist(3):"

    CALL print_real_vector(3*3,Elist(3,:))

    WRITE(*,*)
    WRITE(*,*) "Elist:"

    CALL print_real_matrix(3,3*3,Elist)

    ALLOCATE(F(4,4),w(3))

    CALL DIIS_B(3,elist,3,F)

    WRITE(*,*)
    WRITE(*,*) "Matrix F:"

    CALL print_real_matrix(4,4,F)

    dim = 4
    info = -1

    DO WHILE(info .NE. 0)

        CALL DIIS_weigts(dim,F,w,info)

        IF (info .NE. 0) THEN
            WRITE(*,*)
            WRITE(*,*) "IMPOSSIBLE TO SOLVE THE LINEAR SYSTEM: REDUCING MATRIX F"

            CALL DIIS_reduce_B(dim,F)

            dim = dim - 1

            WRITE(*,*)
            WRITE(*,*) "Reduced matrix F:"

            CALL print_real_matrix(dim,dim,F)

            DEALLOCATE(w)
            ALLOCATE(w(dim-1))
        END IF

    END DO

    WRITE(*,*)
    WRITE(*,*) "Weights:"

    CALL print_real_vector(dim-1,w)

    CALL addFock(3,1,Mlist,A)
    CALL addFock(3,2,Mlist,2*A)
    CALL addFock(3,3,Mlist,3*A)

    j = 3

    A(:,:) = 0.0D0

    DO i = 1,dim-1

        A = A + w(i) * Mlist(j,:,:)

        j = j - 1

    END DO

    WRITE(*,*)
    WRITE(*,*) "New operator A:"

    CALL print_real_matrix(3,3,A)

END PROGRAM DIIS_test


**********************************************************************
C
C     Copyright (C) 1992  Roland W. Freund and Noel M. Nachtigal
C     All rights reserved.
C
C     This code is part of a copyrighted package.  For details, see the
C     file `cpyrit.doc' in the top-level directory.
C
C     *****************************************************************
C     ANY USE OF  THIS CODE CONSTITUTES ACCEPTANCE OF  THE TERMS OF THE
C                             COPYRIGHT NOTICE
C     *****************************************************************
C
C**********************************************************************
C
      SUBROUTINE DAXPBY (N,DZ,DA,DX,DB,DY)
      USE stel_kinds, ONLY: rprec, dp
      IMPLICIT NONE
C
C     Purpose:
C     This subroutine computes DZ = DA * DX + DB * DY.  Several special
C     cases are handled separately:
C        DA =  0.0, DB =  0.0 => DZ = 0.0
C        DA =  0.0, DB =  1.0 => DZ = DY  (this is COPY)
C        DA =  0.0, DB = -1.0 => DZ = -DY
C        DA =  0.0, DB =   DB => DZ = DB * DY  (this is SCAL)
C        DA =  1.0, DB =  0.0 => DZ = DX  (this is COPY)
C        DA =  1.0, DB =  1.0 => DZ = DX + DY
C        DA =  1.0, DB = -1.0 => DZ = DX - DY
C        DA =  1.0, DB =   DB => DZ = DX + DB * DY (this is AXPY)
C        DA = -1.0, DB =  0.0 => DZ = -DX
C        DA = -1.0, DB =  1.0 => DZ = -DX + DY
C        DA = -1.0, DB = -1.0 => DZ = -DX - DY
C        DA = -1.0, DB =   DB => DZ = -DX + DB * DY
C        DA =   DA, DB =  0.0 => DZ = DA * DX  (this is SCAL)
C        DA =   DA, DB =  1.0 => DZ = DA * DX + DY  (this is AXPY)
C        DA =   DA, DB = -1.0 => DZ = DA * DX - DY
C        DA =   DA, DB =   DB => DZ = DA * DX + DB * DY
C     DZ may be the same as DX or DY.
C
C     Parameters:
C     N  = the dimension of the vectors (input).
C     DZ = the vector result (output).
C     DA = scalar multiplier for DX (input).
C     DX = one of the vectors (input).
C     DB = scalar multiplier for DY (input).
C     DY = the other vector (input).
C
C     Noel M. Nachtigal
C     March 23, 1993
C
C**********************************************************************
C
      INTEGER N
      REAL(rprec), PARAMETER :: ZERO = 0, ONE = 1
      REAL(rprec) DA, DB, DX(N), DY(N), DZ(N)
C
C     Local variables.
C
      INTEGER I
C
      IF (N.LE.0) RETURN
C
      IF (DA.EQ.ZERO) THEN
         IF (DB.EQ.ZERO) THEN
C           DA = 0.0, DB = 0.0 => DZ = 0.0.
            DO 10 I = 1, N
               DZ(I) = ZERO
 10         CONTINUE
         ELSE IF (DB.EQ.ONE) THEN
C           DA = 0.0, DB = 1.0 => DZ = DY (this is COPY).
            DO 20 I = 1, N
               DZ(I) = DY(I)
 20         CONTINUE
         ELSE IF (DB.EQ.-ONE) THEN
C           DA = 0.0, DB = -1.0 => DZ = -DY.
            DO 30 I = 1, N
               DZ(I) = -DY(I)
 30         CONTINUE
         ELSE
C           DA = 0.0, DB = DB => DZ = DB * DY (this is SCAL).
            DO 40 I = 1, N
               DZ(I) = DB * DY(I)
 40         CONTINUE
         END IF
      ELSE IF (DA.EQ.ONE) THEN
         IF (DB.EQ.ZERO) THEN
C           DA = 1.0, DB = 0.0 => DZ = DX (this is COPY).
            DO 50 I = 1, N
               DZ(I) = DX(I)
 50         CONTINUE
         ELSE IF (DB.EQ.ONE) THEN
C           DA = 1.0, DB = 1.0 => DZ = DX + DY.
            DO 60 I = 1, N
               DZ(I) = DX(I) + DY(I)
 60         CONTINUE
         ELSE IF (DB.EQ.-ONE) THEN
C           DA = 1.0, DB = -1.0 => DZ = DX - DY.
            DO 70 I = 1, N
               DZ(I) = DX(I) - DY(I)
 70         CONTINUE
         ELSE
C           DA = 1.0, DB = DB => DZ = DX + DB * DY (this is AXPY).
            DO 80 I = 1, N
               DZ(I) = DX(I) + DB * DY(I)
 80         CONTINUE
         END IF
      ELSE IF (DA.EQ.-ONE) THEN
         IF (DB.EQ.ZERO) THEN
C           DA = -1.0, DB = 0.0 => DZ = -DX
            DO 90 I = 1, N
               DZ(I) = -DX(I)
 90         CONTINUE
         ELSE IF (DB.EQ.ONE) THEN
C           DA = -1.0, DB = 1.0 => DZ = -DX + DY
            DO 100 I = 1, N
               DZ(I) = -DX(I) + DY(I)
 100        CONTINUE
         ELSE IF (DB.EQ.-ONE) THEN
C           DA = -1.0, DB = -1.0 => DZ = -DX - DY.
            DO 110 I = 1, N
               DZ(I) = -DX(I) - DY(I)
 110        CONTINUE
         ELSE
C           DA = -1.0, DB = DB => DZ = -DX + DB * DY
            DO 120 I = 1, N
               DZ(I) = -DX(I) + DB * DY(I)
 120        CONTINUE
         END IF
      ELSE
         IF (DB.EQ.ZERO) THEN
C           DA = DA, DB = 0.0 => DZ = DA * DX (this is SCAL).
            DO 130 I = 1, N
               DZ(I) = DA * DX(I)
 130        CONTINUE
         ELSE IF (DB.EQ.ONE) THEN
C           DA = DA, DB = 1.0 => DZ = DA * DX + DY (this is AXPY)
            DO 140 I = 1, N
               DZ(I) = DA * DX(I) + DY(I)
 140        CONTINUE
         ELSE IF (DB.EQ.-ONE) THEN
C           DA = DA, DB = -1.0 => DZ = DA * DX - DY.
            DO 150 I = 1, N
               DZ(I) = DA * DX(I) - DY(I)
 150        CONTINUE
         ELSE
C           DA = DA, DB = DB => DZ = DA * DX + DB * DY.
            DO 160 I = 1, N
               DZ(I) = DA * DX(I) + DB * DY(I)
 160        CONTINUE
         END IF
      END IF
C
      RETURN
      END
C
C**********************************************************************


use, intrinsic :: iso_fortran_env, only : error_unit, sp=>real32, dp=>real64
implicit none

real(sp) :: a32
real(dp) :: a64

real(sp), parameter :: pi32 = 4*atan(1._sp)
real(dp), parameter :: pi64 = 4*atan(1._dp)

if (pi32 == pi64) error stop 'real32 values generally do not exactly equal real64 values'

call timestwo(a32)
call timestwo(a64)

contains

elemental subroutine timestwo(a)

class(*), intent(inout) :: a

select type (a)
  type is (real(sp))
    a = 2*a
  type is (real(dp))
    a = 2*a
  type is (integer)
    a = 2*a
end select

end subroutine timestwo

end program


program problem36
  use euler
  implicit none
  integer, parameter :: limit=1000000
  integer            :: i,answer=0

  do i=1,limit-1
     if (is_palindrome(i) .and. is_binary_palindrome(i)) then
        answer=answer+i
     end if
  end do

  print *, answer

contains
  function is_binary_palindrome(n)
    implicit none
    integer, intent(in)      :: n
    integer                  :: temp,digits,i
    integer*1, dimension(32) :: bits
    logical                  :: is_binary_palindrome
    real*8                   :: temp2

    temp2=log(dble(n))/log(dble(2))
    if (mod(temp2,1.0_8) == 0.0_8) temp2=temp2+0.1
    digits = ceiling(temp2)
    is_binary_palindrome=.true.
    temp=n

    do i=1,digits
       bits(i)=mod(temp,2)
       temp=temp/2
    end do

    do i=1,digits
       if (bits(i) /= bits(digits+1-i)) then
          is_binary_palindrome=.false.
          exit
       end if
    end do
  end function is_binary_palindrome

end program problem36


(* Euler1 in F# *)

let euler x =
    let rec aux i n =
        if i = 0 then n else
            aux (i-1)  (if i % 3 = 0 || i % 5 = 0 then n + i else n)
    in aux x 0

printfn "%i" (euler 999)


!   Copyright 1997 by Ernst W. Mayer. This program may be used and
!   redistributed freely as long as this header is included. You may
!   modify this program freely, as long as any redistribution
!   contains the original header and a summary of any changes made.
!
!   This software is offered "as is," without warranty of any kind.
!   It is intended only for the private recreational use of our
!   audience. If it causes your CPU to go "poof," that's tough.
!
!   Any modifications of this program intended for distribution MUST
!   be put into the public domain, or provided freely to the original
!   author. Under no circumstances is this program, or any program
!   derived from it or making use of it in any way, to be used for
!   commercial activities of any kind without the express written consent
!   of the original author. (Read: you aren't allowed to make money off
!   it without my say-so.)
!
!   If you use this program or any program derived from it in work
!   leading to a publication, proper acknowledgement should be made in
!   said publication.
!
!   The author appreciates if users send bug reports, inquiries related
!   to the software, or reports of useful modifications or novel and
!   interesting applications to him at the following address:
!
!       Ernst Mayer
!       Dept. of Mechanical and Aerospace Engineering
!       Case Western Reserve University
!       10900 Euclid Avenue
!       Cleveland, OH 44106-7222 USA
!       E-mail: mayer@nigel.mae.cwru.edu
!           or  ewmayer@aol.com
!***************

!...
!   Subroutine which replaces a real vector A of length N by its forward DFT.
!
!   Since A is real, only the positive-frequency half of the transform is
!   computed, owing to the conjugate-symmetry of the coefficients. The real
!   coefficients of the transform, F(1) and F(N/2+1), are stored as the real
!   and imaginary parts of the first complex element of the transformed array.
!   For details regarding this kind of storage scheme, cf. "Numerical Recipes
!   (in Fortran or C): the Art of Scientific Computation," 2nd Edition,
!   by Press, Flannery, Teukolsky and Vetterling (Cambridge Univ. Press).
!
!   NOTE: N must be an integer power of 2 - the routine does not check this,
!         so the user must.
!
!   Calls DLANCZOS_FWD.
!
!	This version dated 27 February 1997.
!
!...
	subroutine dfft_fwd(a,n)
!...
	implicit none
	integer, intent(in) :: n
!* look for an extended precision real data type for sincos inits; if none available, use real*8
	integer, parameter :: r16=max(selected_real_kind(18,50),selected_real_kind(15,30))
	integer :: i,i1,i2,i3,i4,np3
	integer, save :: n2,n4
	real*8, intent(inout) :: a(n)
	real*8 :: h1r,h1i,h2r,h2i,t1,t2,t3,t4
	real*8, allocatable, save :: w1(:,:)
	real(kind=r16), save :: mt,one=1,pi,theta
	logical, save :: first_entry=.true.

!...initialize things upon first entry
	if(first_entry) then
	  first_entry=.false.
	  n2=n/2
	  n4=n/4
	  allocate(w1(2,n/4))
	  pi=acos(-one)
	  theta=pi/n2	!* = 2*pi/n
	  do i=2,n4	!* exp(2*pi*i*k/n), k=0, ... , n/4-1 are here
	    mt=(i-1)*theta
	    w1(1,i)=cos(mt)
	    w1(2,i)=sin(mt)
	  enddo
	endif

!...enter transform. Result returned in A.

	call dlanczos_fwd(a,n)

!...the rest is to unscramble the data...
	np3=n+3
	do i=2,n4
	  i1=2*i-1
	  i2=i1+1
	  i3=np3-i2
	  i4=i3+1
!...
	  t1=a(i1)
	  t2=a(i2)
	  t3=a(i3)
	  t4=a(i4)
!...Separate the two transforms
	  h1r= .5d0*(t1+t3)
	  h1i= .5d0*(t2-t4)
	  h2r= .5d0*(t2+t4)
	  h2i= .5d0*(t3-t1)
!...to obtain the true transform of the original real data...
	  t1=w1(1,i)
	  t2=w1(2,i)
	  t3=t1*h2r-t2*h2i
	  t4=t2*h2r+t1*h2i
	  a(i1)= h1r+t3
	  a(i2)= h1i+t4
	  a(i3)= h1r-t3
	  a(i4)= t4-h1i
	enddo
!...squeeze first and last datum together...
	h1r=a(1)
	a(1)=h1r+a(2)
	a(2)=h1r-a(2)
!...
	end subroutine dfft_fwd

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

	subroutine dlanczos_fwd(a,n)
!...
!   Subroutine which replaces a complex vector A of length N/2 by its forward DFT.
	implicit none
	integer, intent(in) :: n
!* if your compiler does not support real(kind=r16), use real*8 and keep an eye out for error warnings
	integer, parameter :: r16=max(selected_real_kind(18,50),selected_real_kind(15,30))
	integer :: i,ilo,ihi,incr,j,j1,j2,j3,j4,j5,j6,j7,j8,k,m,mm,nh,n2bit
	integer, save :: n2,n4,n8
	integer, allocatable, save :: index(:)
	real*8, intent(inout) :: a(n)
	real*8, allocatable, save :: b(:),w2(:,:),w3(:,:)
	real*8, save :: isqrt2
	real*8 :: tr1,tr2,ti1,ti2,tt,c1,s1,c2,s2,c3,s3
	real*8 :: t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16
	real(kind=r16) :: mt,one=1,two=2,pi,theta,theta2,theta4,mt2,mt4
	logical, save :: first_entry=.true.

!...initialize things upon first entry
	if(first_entry) then
	  first_entry=.false.
	  allocate(b(n),index(n))
	  pi=acos(-one)
	  isqrt2=one/sqrt(two)
	  n2=n/2; n2bit=nint(log(1d0*n2)/log(2d0))
	  n4=n/4
	  n8=n/8
!...bit-reversal array is here...
	  do i=1,n
	    index(i)=i
	  enddo
	  j=1
	  do i=1,n,2
	    if(j > i) then
	      k=index(j)
	      index(j)=index(i)
	      index(i)=k
	      k=index(j+1)
	      index(j+1)=index(i+1)
	      index(i+1)=k
	    endif
	    nh=n/2
	    do
	    if( nh < 2 .or. j < nh ) EXIT
	      j=j-nh
	      nh=nh/2
	    enddo
	    j=j+nh
	  enddo
!...trig array is here: first, calculate the needed dimension...
	  j=1
	  mm=1
	  do
	  if( n2 <= mm ) EXIT
	    mm=8*mm
	    j=j+mm
	  enddo
	  j=3*j+1
	  allocate(w2(2,j))
!...then calculate the sincos data. First part is for the radix-8 loops.
	  j=1
	  mm=1
	  do
	  if( n2 <= mm ) EXIT
	    theta =pi/mm
	    theta2=theta /2
	    theta4=theta2/2
	    w2(1,j:j+2)=1d0
	    w2(2,j:j+2)=0d0
	    do m=1,mm
	      mt =m*theta
	      mt2=m*theta2
	      mt4=m*theta4
	      j=j+3
	      w2(1,j  )=cos(mt)
	      w2(2,j  )=sin(mt)
	      w2(1,j+1)=cos(mt2)
	      w2(2,j+1)=sin(mt2)
	      w2(1,j+2)=cos(mt4)
	      w2(2,j+2)=sin(mt4)
	    enddo
	    mm=8*mm
	  enddo
!...Now take care of the radix-2 and radix-4 wrappers.
!...n2 == 1 (mod 3) sincos data are here...
	  if(mod(n2bit,3)==1)then
	    allocate(w3(2,n4))
	    theta =pi/n4
	    w3(1,1)=1d0
	    w3(2,1)=0d0
	    do m=1,n4-1
	      mt =m*theta
	      w3(1,m+1)=cos(mt)
	      w3(2,m+1)=sin(mt)
	    enddo
	  elseif(mod(n2bit,3)==2)then
!...n2 == 2 (mod 3) sincos data are here.
	    allocate(w3(2,n2))
	    theta =pi/n8
	    theta2=theta/2
	    w3(1,1:2)=1d0
	    w3(2,1:2)=0d0
	    do m=1,n4-1
	      mt =m*theta
	      mt2=m*theta2
	      j=2*m+1
	      w3(1,j  )=cos(mt)
	      w3(2,j  )=sin(mt)
	      w3(1,j+1)=cos(mt2)
	      w3(2,j+1)=sin(mt2)
	    enddo
	  endif
	endif

!...Outer loop, which is executed log_2(n2)/3 times, is unrolled in this implementation.
!   We bit-reverse the vector on the first pass triplet. The pass numbering
!   reflects the passes which would be performed in a standard radix-2 algorithm.
!...Passes 1-3...
	  incr=n
	  ilo=1; ihi=incr
	    do i=ilo,ihi,16
!	get indices are here
	      j1=index(i  )
	      j2=index(i+2)
	      j3=index(i+4)
	      j4=index(i+6)
	      j5=index(i+8)
	      j6=index(i+10)
	      j7=index(i+12)
	      j8=index(i+14)
!	gather the needed data (8 64-byte complex, i.e. 16 64-byte reals)...
	      t1 =a(j1  )
	      t2 =a(j1+1)
	      t3 =a(j2)
	      t4 =a(j2+1)
	      t5 =a(j3)
	      t6 =a(j3+1)
	      t7 =a(j4)
	      t8 =a(j4+1)
	      t9 =a(j5)
	      t10=a(j5+1)
	      t11=a(j6)
	      t12=a(j6+1)
	      t13=a(j7)
	      t14=a(j7+1)
	      t15=a(j8)
	      t16=a(j8+1)
!	first get the 4 length-2 transforms...
	      tt=t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tt =t11
	      t11=t9 -tt
	      t9 =t9 +tt
	      tt =t12
	      t12=t10-tt
	      t10=t10+tt
	      tt =t15
	      t15=t13-tt
	      t13=t13+tt
	      tt =t16
	      t16=t14-tt
	      t14=t14+tt
!	combine to get the 2 length-4 transform...
	      tr1=t5
	      ti1=t6
	      tr2=t7
	      ti2=t8
	      t5=t1-tr1
	      t1=t1+tr1
	      t6=t2-ti1
	      t2=t2+ti1
	      t7=t3+ti2
	      t3=t3-ti2
	      t8=t4-tr2
	      t4=t4+tr2

	      tr1=t13
	      ti1=t14
	      tr2=t15
	      ti2=t16
	      t13=t9 -tr1
	      t9 =t9 +tr1
	      t14=t10-ti1
	      t10=t10+ti1
	      t15=t11+ti2
	      t11=t11-ti2
	      t16=t12-tr2
	      t12=t12+tr2
!	put indices are here
	      j1=ishft(i,-3)+1
	      j2=j1+n8
	      j3=j2+n8
	      j4=j3+n8
	      j5=j4+n8
	      j6=j5+n8
	      j7=j6+n8
	      j8=j7+n8
!	now combine the two half-transforms.
	      b(j1  )=t1+t9
	      b(j1+1)=t2+t10
	      b(j5  )=t1-t9
	      b(j5+1)=t2-t10

	      tr1=(t11-t12)*isqrt2	!* mpy by (1+i)/sqrt(2) is here...
	      ti1=(t11+t12)*isqrt2
	      b(j2  )=t3+tr1
	      b(j2+1)=t4+ti1
	      b(j6  )=t3-tr1
	      b(j6+1)=t4-ti1

	      b(j3  )=t5-t14		!* mpy by i is inlined here...
	      b(j3+1)=t6+t13
	      b(j7  )=t5+t14
	      b(j7+1)=t6-t13

	      tr1=(t15+t16)*isqrt2	!* mpy by (1-i)/sqrt(2) is here...
	      ti1=(t16-t15)*isqrt2
	      b(j4  )=t7-tr1		!* and get (i-1)/sqrt by flipping signs here.
	      b(j4+1)=t8-ti1
	      b(j8  )=t7+tr1
	      b(j8+1)=t8+ti1
	    enddo
	if(n2==8)then; a=b; RETURN; endif
!...Pass 4...
	incr=incr/8
	if(n2==16)then
	  ilo=1; ihi=incr
	  do m=1,8
	    c1=w3(1,m)
	    s1=w3(2,m)
	    do i=ilo,ihi,4
	      j1=ishft(i,-1)+1
	      j2=j1+n2
	      t1=b(i  )
	      t2=b(i+1)
	      t3=b(i+2)
	      t4=b(i+3)
	      tr1=c1*t3-s1*t4
	      ti1=c1*t4+s1*t3
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j2  )=t1-tr1
	      a(j2+1)=t2-ti1
	    enddo
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  RETURN
	endif
!...Passes 4 and 5...
	if(n2==32)then
	  ilo=1; ihi=incr
	  j=1
	  do m=1,8
	    c1=w3(1,j  )
	    s1=w3(2,j  )
	    c2=w3(1,j+1)
	    s2=w3(2,j+1)
	    do i=ilo,ihi,8
	      j1=ishft(i,-2)+1
	      j2=j1+n4
	      j3=j2+n4
	      j4=j3+n4
	      t1=b(i  )
	      t2=b(i+1)
	      t3=b(i+2)
	      t4=b(i+3)
	      t5=b(i+4)
	      t6=b(i+5)
	      t7=b(i+6)
	      t8=b(i+7)
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      tr2=c2*t7-s2*t8
	      ti2=c2*t8+s2*t7
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j2  )=t3-ti2
	      a(j2+1)=t4+tr2
	      a(j3  )=t1-tr1
	      a(j3+1)=t2-ti1
	      a(j4  )=t3+ti2
	      a(j4+1)=t4-tr2
	    enddo
	    j=j+2
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  RETURN
	endif
!...Passes 4-6...
	  j=4	!* 3*(1)+1
	  ilo=1; ihi=incr
	  do m=1,8
	    c1=w2(1,j  )
	    s1=w2(2,j  )
	    c2=w2(1,j+1)
	    s2=w2(2,j+1)
	    c3=w2(1,j+2)
	    s3=w2(2,j+2)
	    tr2=c3*isqrt2
	    ti2=s3*isqrt2
	    do i=ilo,ihi,16
!	put indices are here
	      j1=ishft(i,-3)+1
	      j2=j1+n8
	      j3=j2+n8
	      j4=j3+n8
	      j5=j4+n8
	      j6=j5+n8
	      j7=j6+n8
	      j8=j7+n8
!	gather the needed data (8 64-byte complex, i.e. 16 64-byte reals)...
	      t1 =b(i  )
	      t2 =b(i+1)
	      t3 =b(i+2)
	      t4 =b(i+3)
	      t5 =b(i+4)
	      t6 =b(i+5)
	      t7 =b(i+6)
	      t8 =b(i+7)
	      t9 =b(i+8)
	      t10=b(i+9)
	      t11=b(i+10)
	      t12=b(i+11)
	      t13=b(i+12)
	      t14=b(i+13)
	      t15=b(i+14)
	      t16=b(i+15)
!	first get the 4 length-2 transforms...
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tt =c1*t11-s1*t12
	      t12=c1*t12+s1*t11
	      t11=t9 -tt
	      t9 =t9 +tt
	      tt =t12
	      t12=t10-tt
	      t10=t10+tt
	      tt =c1*t15-s1*t16
	      t16=c1*t16+s1*t15
	      t15=t13-tt
	      t13=t13+tt
	      tt =t16
	      t16=t14-tt
	      t14=t14+tt
!	combine to get the 2 length-4 transform...
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      t5=t1-tr1
	      t1=t1+tr1
	      t6=t2-ti1
	      t2=t2+ti1
	      tr1=c2*t7-s2*t8
	      ti1=c2*t8+s2*t7
	      t7=t3+ti1
	      t3=t3-ti1
	      t8=t4-tr1
	      t4=t4+tr1
	      tr1=c2*t13-s2*t14
	      ti1=c2*t14+s2*t13
	      t13=t9 -tr1
	      t9 =t9 +tr1
	      t14=t10-ti1
	      t10=t10+ti1
	      tr1=c2*t15-s2*t16
	      ti1=c2*t16+s2*t15
	      t15=t11+ti1
	      t11=t11-ti1
	      t16=t12-tr1
	      t12=t12+tr1
!	now combine the two half-transforms
	      tr1=c3*t9 -s3*t10
	      ti1=c3*t10+s3*t9
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j5  )=t1-tr1
	      a(j5+1)=t2-ti1

	      tt =tr2*t11-ti2*t12
	      ti1=tr2*t12+ti2*t11
	      tr1=tt-ti1		!* mpy by (1+i)/sqrt(2) is here...
	      ti1=tt+ti1
	      a(j2  )=t3+tr1
	      a(j2+1)=t4+ti1
	      a(j6  )=t3-tr1
	      a(j6+1)=t4-ti1

	      tr1=c3*t13-s3*t14
	      ti1=c3*t14+s3*t13
	      a(j3  )=t5-ti1		!* mpy by i is inlined here...
	      a(j3+1)=t6+tr1
	      a(j7  )=t5+ti1
	      a(j7+1)=t6-tr1

	      tt =tr2*t15-ti2*t16
	      ti1=tr2*t16+ti2*t15
	      tr1=tt+ti1		!* mpy by (1-i)/sqrt(2) is here...
	      ti1=ti1-tt
	      a(j4  )=t7-tr1		!* and get (i-1)/sqrt by flipping signs here.
	      a(j4+1)=t8-ti1
	      a(j8  )=t7+tr1
	      a(j8+1)=t8+ti1
	    enddo
	    j=j+3
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	if(n2==64)RETURN
!...Pass 7...
	incr=incr/8
	if(n2==128)then
	  ilo=1; ihi=incr
	  do m=1,64
	    c1=w3(1,m)
	    s1=w3(2,m)
	    do i=ilo,ihi,4
	      j1=ishft(i,-1)+1
	      j2=j1+n2
	      t1=a(i  )
	      t2=a(i+1)
	      t3=a(i+2)
	      t4=a(i+3)
	      tr1=c1*t3-s1*t4
	      ti1=c1*t4+s1*t3
	      b(j1  )=t1+tr1
	      b(j1+1)=t2+ti1
	      b(j2  )=t1-tr1
	      b(j2+1)=t2-ti1
	    enddo
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  a=b; RETURN
	endif
!...Passes 7 and 8...
	if(n2==256)then
	  ilo=1; ihi=incr
	  j=1
	  do m=1,64
	    c1=w3(1,j  )
	    s1=w3(2,j  )
	    c2=w3(1,j+1)
	    s2=w3(2,j+1)
	    do i=ilo,ihi,8
	      j1=ishft(i,-2)+1
	      j2=j1+n4
	      j3=j2+n4
	      j4=j3+n4
	      t1=a(i  )
	      t2=a(i+1)
	      t3=a(i+2)
	      t4=a(i+3)
	      t5=a(i+4)
	      t6=a(i+5)
	      t7=a(i+6)
	      t8=a(i+7)
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      tr2=c2*t7-s2*t8
	      ti2=c2*t8+s2*t7
	      b(j1  )=t1+tr1
	      b(j1+1)=t2+ti1
	      b(j2  )=t3-ti2
	      b(j2+1)=t4+tr2
	      b(j3  )=t1-tr1
	      b(j3+1)=t2-ti1
	      b(j4  )=t3+ti2
	      b(j4+1)=t4-tr2
	    enddo
	    j=j+2
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  a=b; RETURN
	endif
!...Passes 7-9...
	  j=28	!* 3*(1+8)+1
	  ilo=1; ihi=incr
	  do m=1,64
	    c1=w2(1,j  )
	    s1=w2(2,j  )
	    c2=w2(1,j+1)
	    s2=w2(2,j+1)
	    c3=w2(1,j+2)
	    s3=w2(2,j+2)
	    tr2=c3*isqrt2
	    ti2=s3*isqrt2
	    do i=ilo,ihi,16
!	put indices are here
	      j1=ishft(i,-3)+1
	      j2=j1+n8
	      j3=j2+n8
	      j4=j3+n8
	      j5=j4+n8
	      j6=j5+n8
	      j7=j6+n8
	      j8=j7+n8
!	gather the needed data (8 64-byte complex, i.e. 16 64-byte reals)...
	      t1 =a(i  )
	      t2 =a(i+1)
	      t3 =a(i+2)
	      t4 =a(i+3)
	      t5 =a(i+4)
	      t6 =a(i+5)
	      t7 =a(i+6)
	      t8 =a(i+7)
	      t9 =a(i+8)
	      t10=a(i+9)
	      t11=a(i+10)
	      t12=a(i+11)
	      t13=a(i+12)
	      t14=a(i+13)
	      t15=a(i+14)
	      t16=a(i+15)
!	first get the 4 length-2 transforms...
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tt =c1*t11-s1*t12
	      t12=c1*t12+s1*t11
	      t11=t9 -tt
	      t9 =t9 +tt
	      tt =t12
	      t12=t10-tt
	      t10=t10+tt
	      tt =c1*t15-s1*t16
	      t16=c1*t16+s1*t15
	      t15=t13-tt
	      t13=t13+tt
	      tt =t16
	      t16=t14-tt
	      t14=t14+tt
!	combine to get the 2 length-4 transform...
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      t5=t1-tr1
	      t1=t1+tr1
	      t6=t2-ti1
	      t2=t2+ti1
	      tr1=c2*t7-s2*t8
	      ti1=c2*t8+s2*t7
	      t7=t3+ti1
	      t3=t3-ti1
	      t8=t4-tr1
	      t4=t4+tr1
	      tr1=c2*t13-s2*t14
	      ti1=c2*t14+s2*t13
	      t13=t9 -tr1
	      t9 =t9 +tr1
	      t14=t10-ti1
	      t10=t10+ti1
	      tr1=c2*t15-s2*t16
	      ti1=c2*t16+s2*t15
	      t15=t11+ti1
	      t11=t11-ti1
	      t16=t12-tr1
	      t12=t12+tr1
!	now combine the two half-transforms
	      tr1=c3*t9 -s3*t10
	      ti1=c3*t10+s3*t9
	      b(j1  )=t1+tr1
	      b(j1+1)=t2+ti1
	      b(j5  )=t1-tr1
	      b(j5+1)=t2-ti1

	      tt =tr2*t11-ti2*t12
	      ti1=tr2*t12+ti2*t11
	      tr1=tt-ti1		!* mpy by (1+i)/sqrt(2) is here...
	      ti1=tt+ti1
	      b(j2  )=t3+tr1
	      b(j2+1)=t4+ti1
	      b(j6  )=t3-tr1
	      b(j6+1)=t4-ti1

	      tr1=c3*t13-s3*t14
	      ti1=c3*t14+s3*t13
	      b(j3  )=t5-ti1		!* mpy by i is inlined here...
	      b(j3+1)=t6+tr1
	      b(j7  )=t5+ti1
	      b(j7+1)=t6-tr1

	      tt =tr2*t15-ti2*t16
	      ti1=tr2*t16+ti2*t15
	      tr1=tt+ti1		!* mpy by (1-i)/sqrt(2) is here...
	      ti1=ti1-tt
	      b(j4  )=t7-tr1		!* and get (i-1)/sqrt by flipping signs here.
	      b(j4+1)=t8-ti1
	      b(j8  )=t7+tr1
	      b(j8+1)=t8+ti1
	    enddo
	    j=j+3
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	if(n2==512)then; a=b; RETURN; endif
!...Pass 10...
	incr=incr/8
	if(n2==1024)then
	  ilo=1; ihi=incr
	  do m=1,512
	    c1=w3(1,m)
	    s1=w3(2,m)
	    do i=ilo,ihi,4
	      j1=ishft(i,-1)+1
	      j2=j1+n2
	      t1=b(i  )
	      t2=b(i+1)
	      t3=b(i+2)
	      t4=b(i+3)
	      tr1=c1*t3-s1*t4
	      ti1=c1*t4+s1*t3
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j2  )=t1-tr1
	      a(j2+1)=t2-ti1
	    enddo
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  RETURN
	endif
!...Passes 10 and 11...
	if(n2==2048)then
	  ilo=1; ihi=incr
	  j=1
	  do m=1,512
	    c1=w3(1,j  )
	    s1=w3(2,j  )
	    c2=w3(1,j+1)
	    s2=w3(2,j+1)
	    do i=ilo,ihi,8
	      j1=ishft(i,-2)+1
	      j2=j1+n4
	      j3=j2+n4
	      j4=j3+n4
	      t1=b(i  )
	      t2=b(i+1)
	      t3=b(i+2)
	      t4=b(i+3)
	      t5=b(i+4)
	      t6=b(i+5)
	      t7=b(i+6)
	      t8=b(i+7)
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      tr2=c2*t7-s2*t8
	      ti2=c2*t8+s2*t7
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j2  )=t3-ti2
	      a(j2+1)=t4+tr2
	      a(j3  )=t1-tr1
	      a(j3+1)=t2-ti1
	      a(j4  )=t3+ti2
	      a(j4+1)=t4-tr2
	    enddo
	    j=j+2
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  RETURN
	endif
!...Passes 10-12...
	  j=220	!* 3*(1+8+64)+1
	  ilo=1; ihi=incr
	  do m=1,512
	    c1=w2(1,j  )
	    s1=w2(2,j  )
	    c2=w2(1,j+1)
	    s2=w2(2,j+1)
	    c3=w2(1,j+2)
	    s3=w2(2,j+2)
	    tr2=c3*isqrt2
	    ti2=s3*isqrt2
	    do i=ilo,ihi,16
!	put indices are here
	      j1=ishft(i,-3)+1
	      j2=j1+n8
	      j3=j2+n8
	      j4=j3+n8
	      j5=j4+n8
	      j6=j5+n8
	      j7=j6+n8
	      j8=j7+n8
!	gather the needed data (8 64-byte complex, i.e. 16 64-byte reals)...
	      t1 =b(i  )
	      t2 =b(i+1)
	      t3 =b(i+2)
	      t4 =b(i+3)
	      t5 =b(i+4)
	      t6 =b(i+5)
	      t7 =b(i+6)
	      t8 =b(i+7)
	      t9 =b(i+8)
	      t10=b(i+9)
	      t11=b(i+10)
	      t12=b(i+11)
	      t13=b(i+12)
	      t14=b(i+13)
	      t15=b(i+14)
	      t16=b(i+15)
!	first get the 4 length-2 transforms...
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tt =c1*t11-s1*t12
	      t12=c1*t12+s1*t11
	      t11=t9 -tt
	      t9 =t9 +tt
	      tt =t12
	      t12=t10-tt
	      t10=t10+tt
	      tt =c1*t15-s1*t16
	      t16=c1*t16+s1*t15
	      t15=t13-tt
	      t13=t13+tt
	      tt =t16
	      t16=t14-tt
	      t14=t14+tt
!	combine to get the 2 length-4 transform...
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      t5=t1-tr1
	      t1=t1+tr1
	      t6=t2-ti1
	      t2=t2+ti1
	      tr1=c2*t7-s2*t8
	      ti1=c2*t8+s2*t7
	      t7=t3+ti1
	      t3=t3-ti1
	      t8=t4-tr1
	      t4=t4+tr1
	      tr1=c2*t13-s2*t14
	      ti1=c2*t14+s2*t13
	      t13=t9 -tr1
	      t9 =t9 +tr1
	      t14=t10-ti1
	      t10=t10+ti1
	      tr1=c2*t15-s2*t16
	      ti1=c2*t16+s2*t15
	      t15=t11+ti1
	      t11=t11-ti1
	      t16=t12-tr1
	      t12=t12+tr1
!	now combine the two half-transforms
	      tr1=c3*t9 -s3*t10
	      ti1=c3*t10+s3*t9
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j5  )=t1-tr1
	      a(j5+1)=t2-ti1

	      tt =tr2*t11-ti2*t12
	      ti1=tr2*t12+ti2*t11
	      tr1=tt-ti1		!* mpy by (1+i)/sqrt(2) is here...
	      ti1=tt+ti1
	      a(j2  )=t3+tr1
	      a(j2+1)=t4+ti1
	      a(j6  )=t3-tr1
	      a(j6+1)=t4-ti1

	      tr1=c3*t13-s3*t14
	      ti1=c3*t14+s3*t13
	      a(j3  )=t5-ti1		!* mpy by i is inlined here...
	      a(j3+1)=t6+tr1
	      a(j7  )=t5+ti1
	      a(j7+1)=t6-tr1

	      tt =tr2*t15-ti2*t16
	      ti1=tr2*t16+ti2*t15
	      tr1=tt+ti1		!* mpy by (1-i)/sqrt(2) is here...
	      ti1=ti1-tt
	      a(j4  )=t7-tr1		!* and get (i-1)/sqrt by flipping signs here.
	      a(j4+1)=t8-ti1
	      a(j8  )=t7+tr1
	      a(j8+1)=t8+ti1
	    enddo
	    j=j+3
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	if(n2==4096)RETURN
!...Pass 13...
	incr=incr/8
	if(n2==8192)then
	  ilo=1; ihi=incr
	  do m=1,4096
	    c1=w3(1,m)
	    s1=w3(2,m)
	    do i=ilo,ihi,4
	      j1=ishft(i,-1)+1
	      j2=j1+n2
	      t1=a(i  )
	      t2=a(i+1)
	      t3=a(i+2)
	      t4=a(i+3)
	      tr1=c1*t3-s1*t4
	      ti1=c1*t4+s1*t3
	      b(j1  )=t1+tr1
	      b(j1+1)=t2+ti1
	      b(j2  )=t1-tr1
	      b(j2+1)=t2-ti1
	    enddo
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  a=b; RETURN
	endif
!...Passes 13 and 14...
	if(n2==16384)then
	  ilo=1; ihi=incr
	  j=1
	  do m=1,4096
	    c1=w3(1,j  )
	    s1=w3(2,j  )
	    c2=w3(1,j+1)
	    s2=w3(2,j+1)
	    do i=ilo,ihi,8
	      j1=ishft(i,-2)+1
	      j2=j1+n4
	      j3=j2+n4
	      j4=j3+n4
	      t1=a(i  )
	      t2=a(i+1)
	      t3=a(i+2)
	      t4=a(i+3)
	      t5=a(i+4)
	      t6=a(i+5)
	      t7=a(i+6)
	      t8=a(i+7)
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      tr2=c2*t7-s2*t8
	      ti2=c2*t8+s2*t7
	      b(j1  )=t1+tr1
	      b(j1+1)=t2+ti1
	      b(j2  )=t3-ti2
	      b(j2+1)=t4+tr2
	      b(j3  )=t1-tr1
	      b(j3+1)=t2-ti1
	      b(j4  )=t3+ti2
	      b(j4+1)=t4-tr2
	    enddo
	    j=j+2
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  a=b; RETURN
	endif
!...Passes 13-15...
	  j=1756	!* 3*(1+8+64+512)+1
	  ilo=1; ihi=incr
	  do m=1,4096
	    c1=w2(1,j  )
	    s1=w2(2,j  )
	    c2=w2(1,j+1)
	    s2=w2(2,j+1)
	    c3=w2(1,j+2)
	    s3=w2(2,j+2)
	    tr2=c3*isqrt2
	    ti2=s3*isqrt2
	    do i=ilo,ihi,16
!	put indices are here
	      j1=ishft(i,-3)+1
	      j2=j1+n8
	      j3=j2+n8
	      j4=j3+n8
	      j5=j4+n8
	      j6=j5+n8
	      j7=j6+n8
	      j8=j7+n8
!	gather the needed data (8 64-byte complex, i.e. 16 64-byte reals)...
	      t1 =a(i  )
	      t2 =a(i+1)
	      t3 =a(i+2)
	      t4 =a(i+3)
	      t5 =a(i+4)
	      t6 =a(i+5)
	      t7 =a(i+6)
	      t8 =a(i+7)
	      t9 =a(i+8)
	      t10=a(i+9)
	      t11=a(i+10)
	      t12=a(i+11)
	      t13=a(i+12)
	      t14=a(i+13)
	      t15=a(i+14)
	      t16=a(i+15)
!	first get the 4 length-2 transforms...
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tt =c1*t11-s1*t12
	      t12=c1*t12+s1*t11
	      t11=t9 -tt
	      t9 =t9 +tt
	      tt =t12
	      t12=t10-tt
	      t10=t10+tt
	      tt =c1*t15-s1*t16
	      t16=c1*t16+s1*t15
	      t15=t13-tt
	      t13=t13+tt
	      tt =t16
	      t16=t14-tt
	      t14=t14+tt
!	combine to get the 2 length-4 transform...
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      t5=t1-tr1
	      t1=t1+tr1
	      t6=t2-ti1
	      t2=t2+ti1
	      tr1=c2*t7-s2*t8
	      ti1=c2*t8+s2*t7
	      t7=t3+ti1
	      t3=t3-ti1
	      t8=t4-tr1
	      t4=t4+tr1
	      tr1=c2*t13-s2*t14
	      ti1=c2*t14+s2*t13
	      t13=t9 -tr1
	      t9 =t9 +tr1
	      t14=t10-ti1
	      t10=t10+ti1
	      tr1=c2*t15-s2*t16
	      ti1=c2*t16+s2*t15
	      t15=t11+ti1
	      t11=t11-ti1
	      t16=t12-tr1
	      t12=t12+tr1
!	now combine the two half-transforms
	      tr1=c3*t9 -s3*t10
	      ti1=c3*t10+s3*t9
	      b(j1  )=t1+tr1
	      b(j1+1)=t2+ti1
	      b(j5  )=t1-tr1
	      b(j5+1)=t2-ti1

	      tt =tr2*t11-ti2*t12
	      ti1=tr2*t12+ti2*t11
	      tr1=tt-ti1		!* mpy by (1+i)/sqrt(2) is here...
	      ti1=tt+ti1
	      b(j2  )=t3+tr1
	      b(j2+1)=t4+ti1
	      b(j6  )=t3-tr1
	      b(j6+1)=t4-ti1

	      tr1=c3*t13-s3*t14
	      ti1=c3*t14+s3*t13
	      b(j3  )=t5-ti1		!* mpy by i is inlined here...
	      b(j3+1)=t6+tr1
	      b(j7  )=t5+ti1
	      b(j7+1)=t6-tr1

	      tt =tr2*t15-ti2*t16
	      ti1=tr2*t16+ti2*t15
	      tr1=tt+ti1		!* mpy by (1-i)/sqrt(2) is here...
	      ti1=ti1-tt
	      b(j4  )=t7-tr1		!* and get (i-1)/sqrt by flipping signs here.
	      b(j4+1)=t8-ti1
	      b(j8  )=t7+tr1
	      b(j8+1)=t8+ti1
	    enddo
	    j=j+3
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	if(n2==32768)then; a=b; RETURN; endif
!...Pass 16...
	incr=incr/8
	if(n2==65536)then
	  ilo=1; ihi=incr
	  do m=1,32768
	    c1=w3(1,m)
	    s1=w3(2,m)
	    do i=ilo,ihi,4
	      j1=ishft(i,-1)+1
	      j2=j1+n2
	      t1=b(i  )
	      t2=b(i+1)
	      t3=b(i+2)
	      t4=b(i+3)
	      tr1=c1*t3-s1*t4
	      ti1=c1*t4+s1*t3
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j2  )=t1-tr1
	      a(j2+1)=t2-ti1
	    enddo
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  RETURN
	endif
!...Passes 16 and 17...
	if(n2==131072)then
	  ilo=1; ihi=incr
	  j=1
	  do m=1,32768
	    c1=w3(1,j  )
	    s1=w3(2,j  )
	    c2=w3(1,j+1)
	    s2=w3(2,j+1)
	    do i=ilo,ihi,8
	      j1=ishft(i,-2)+1
	      j2=j1+n4
	      j3=j2+n4
	      j4=j3+n4
	      t1=b(i  )
	      t2=b(i+1)
	      t3=b(i+2)
	      t4=b(i+3)
	      t5=b(i+4)
	      t6=b(i+5)
	      t7=b(i+6)
	      t8=b(i+7)
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      tr2=c2*t7-s2*t8
	      ti2=c2*t8+s2*t7
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j2  )=t3-ti2
	      a(j2+1)=t4+tr2
	      a(j3  )=t1-tr1
	      a(j3+1)=t2-ti1
	      a(j4  )=t3+ti2
	      a(j4+1)=t4-tr2
	    enddo
	    j=j+2
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	  RETURN
	endif
!...Passes 16-18...
	  j=14044	!* 3*(1+8+64+512+4096)+1
	  ilo=1; ihi=incr
	  do m=1,32768
	    c1=w2(1,j  )
	    s1=w2(2,j  )
	    c2=w2(1,j+1)
	    s2=w2(2,j+1)
	    c3=w2(1,j+2)
	    s3=w2(2,j+2)
	    tr2=c3*isqrt2
	    ti2=s3*isqrt2
	    do i=ilo,ihi,16
!	put indices are here
	      j1=ishft(i,-3)+1
	      j2=j1+n8
	      j3=j2+n8
	      j4=j3+n8
	      j5=j4+n8
	      j6=j5+n8
	      j7=j6+n8
	      j8=j7+n8
!	gather the needed data (8 64-byte complex, i.e. 16 64-byte reals)...
	      t1 =b(i  )
	      t2 =b(i+1)
	      t3 =b(i+2)
	      t4 =b(i+3)
	      t5 =b(i+4)
	      t6 =b(i+5)
	      t7 =b(i+6)
	      t8 =b(i+7)
	      t9 =b(i+8)
	      t10=b(i+9)
	      t11=b(i+10)
	      t12=b(i+11)
	      t13=b(i+12)
	      t14=b(i+13)
	      t15=b(i+14)
	      t16=b(i+15)
!	first get the 4 length-2 transforms...
	      tt=c1*t3-s1*t4
	      t4=c1*t4+s1*t3
	      t3=t1-tt
	      t1=t1+tt
	      tt=t4
	      t4=t2-tt
	      t2=t2+tt
	      tt=c1*t7-s1*t8
	      t8=c1*t8+s1*t7
	      t7=t5-tt
	      t5=t5+tt
	      tt=t8
	      t8=t6-tt
	      t6=t6+tt
	      tt =c1*t11-s1*t12
	      t12=c1*t12+s1*t11
	      t11=t9 -tt
	      t9 =t9 +tt
	      tt =t12
	      t12=t10-tt
	      t10=t10+tt
	      tt =c1*t15-s1*t16
	      t16=c1*t16+s1*t15
	      t15=t13-tt
	      t13=t13+tt
	      tt =t16
	      t16=t14-tt
	      t14=t14+tt
!	combine to get the 2 length-4 transform...
	      tr1=c2*t5-s2*t6
	      ti1=c2*t6+s2*t5
	      t5=t1-tr1
	      t1=t1+tr1
	      t6=t2-ti1
	      t2=t2+ti1
	      tr1=c2*t7-s2*t8
	      ti1=c2*t8+s2*t7
	      t7=t3+ti1
	      t3=t3-ti1
	      t8=t4-tr1
	      t4=t4+tr1
	      tr1=c2*t13-s2*t14
	      ti1=c2*t14+s2*t13
	      t13=t9 -tr1
	      t9 =t9 +tr1
	      t14=t10-ti1
	      t10=t10+ti1
	      tr1=c2*t15-s2*t16
	      ti1=c2*t16+s2*t15
	      t15=t11+ti1
	      t11=t11-ti1
	      t16=t12-tr1
	      t12=t12+tr1
!	now combine the two half-transforms
	      tr1=c3*t9 -s3*t10
	      ti1=c3*t10+s3*t9
	      a(j1  )=t1+tr1
	      a(j1+1)=t2+ti1
	      a(j5  )=t1-tr1
	      a(j5+1)=t2-ti1

	      tt =tr2*t11-ti2*t12
	      ti1=tr2*t12+ti2*t11
	      tr1=tt-ti1		!* mpy by (1+i)/sqrt(2) is here...
	      ti1=tt+ti1
	      a(j2  )=t3+tr1
	      a(j2+1)=t4+ti1
	      a(j6  )=t3-tr1
	      a(j6+1)=t4-ti1

	      tr1=c3*t13-s3*t14
	      ti1=c3*t14+s3*t13
	      a(j3  )=t5-ti1		!* mpy by i is inlined here...
	      a(j3+1)=t6+tr1
	      a(j7  )=t5+ti1
	      a(j7+1)=t6-tr1

	      tt =tr2*t15-ti2*t16
	      ti1=tr2*t16+ti2*t15
	      tr1=tt+ti1		!* mpy by (1-i)/sqrt(2) is here...
	      ti1=ti1-tt
	      a(j4  )=t7-tr1		!* and get (i-1)/sqrt by flipping signs here.
	      a(j4+1)=t8-ti1
	      a(j8  )=t7+tr1
	      a(j8+1)=t8+ti1
	    enddo
	    j=j+3
	    ilo=ilo+incr; ihi=ihi+incr
	  enddo
	if(n2==262144)RETURN
!...
	print*,'FFT length not a power of 2 or out of range'
	STOP
!...
	end subroutine dlanczos_fwd


program funcao2

implicit none
double precision :: r, v, pi
real, dimension (1:100) :: x, y
real, dimension (1:3) :: a,b,c
real :: pe, soma

!VETORES!
!do c = 1,100
!    x(c) = 2*c
!end do

!do c = 1,100
!    y(c) = c
!end do
!VETORES!

!SUBROTINA"
!read(*,*) r
!    call circulo(r,v,a)
!write(*,*) "O valor da área do círculo é", a, "o valor do volume da esfera é", v
!SUBROTINA!

write(*,*) "Digite as coordenadas do vetor 'a'"
read(*,*) a(1), a(2), a(3)
write(*,*) "Digite as coordenadas do vetor 'b'"
read(*,*) b(1), b(2), b(3)

call vetorial(a,b,c)

write(*,*) "O vetor do produto vetorial é"
write(*,*) c(1), c(2), c(3)

end program

!FUNÇÃO PARA CALCULAR O PRODUTO INTERNO ENTRE DOIS VETORES!
function pe(x,y)
real :: pe, cont
real, dimension (1:100) :: x, y
integer :: c

cont = 0
do c = 1,100
    cont = cont + (x(c)*y(c))
    pe = cont
end do

return
end function pe
!**********************************************************!

!SUBROTINA PARA CALCULAR O PRODUTO VETORIAL ENTRE DOIS VETORES!
subroutine vetorial(a,b,c)
real, dimension (1:3) :: a, b, c

c(1) = a(2)*b(3)-a(3)*b(2)
c(2) = a(3)*b(1)-a(1)*b(3)
c(3) = a(1)*b(2)-a(2)*b(1)

return
end subroutine vetorial
!***********************************************************!
!FUNÇÃO PARA CALCULAR A SOMATÓRIA PARTINDO DE UM VETOR!
function soma(x)
real :: soma, cont
real, dimension (1:100) :: x
integer :: c

cont = 0
do c = 1,100
    cont = cont + x(c)
    soma = cont
end do

return
end function soma
!***********************************************************!

!SUBROTINA !
subroutine circulo(r, v, a)
double precision :: r, v, a, pi

pi = 3.1415
v = (4d0/3d0)*pi*r**3
a = pi*r**2

return
end subroutine circulo
!***********************************************************!


program simpson_test
        use numerical_integration
        implicit none
        integer, parameter :: n = 101, dp = selected_real_kind(14)
        integer :: i
        real(kind=dp), dimension(0:n-1) :: x, y
        real(kind=dp) :: sum

        sum=0.0d0
        do i=0,n-1
                x(i) = dfloat(i)/(n-1)
                y(i) = x(i)
        end do

        sum = simpson(x,y,n)
        write(*,*) sum

end program simpson_test


       integer function  OWNEROF(ig,nx,npx)
!
!   INPUT :
!           ig  global index of the x dimension of array element
!
!           nx  x dimension of the global array
!
!           npx  number of processor in the x dimension of the processors grid
!
!   OUTPUT :
!

       IMPLICIT NONE

       INTEGER ig,nx,npx,r,q,pex

       q = int(nx/npx)
       r = mod(nx,npx)
       if(r.gt.0) then
         if(ig.le.((q+1)*r)) then
            pex = int((ig-1)/(q+1))+1
         else
            pex = int((ig-1-r*(q+1))/q)+1+r
         end if
       else
         pex = int((ig-1)/q)+1
       end if

       ownerof = pex

       RETURN
       END


C     LINEAR ALGEBRA
      SUBROUTINE DECOMP(N,NDIM,A,IP)
      REAL A(NDIM,NDIM),T
      INTEGER IP(NDIM)
C     MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION.
C     N = ORDER OF MATRIX. NDIM = DECLARED DIMENSION OF ARRAY A.
C     A = MATRIX TO BE TRIANGULARIZED.
C     IP(K) , K .LT. N = INDEX OF K-TH PIVOT ROW.
      IP(N) = 1
      DO 6 K = 1, N
         IF(K.EQ.N) GOTO 5
         KP1 = K + 1
         M = K
         DO 1 I = KP1, N
            IF( ABS(A(I,K)).GT.ABS(A(M,K))) M=I
 1       CONTINUE

         IP(K) = M
         IF(M.NE.K) IP(N) = -IP(N)
         T = A(M,K)
         A(M,K) = A(K,K)
         A(K,K) = T
         IF(T.EQ.0.E0) GO TO 5

         DO 2 I = KP1, N
 2          A(I,K) = -A(I,K)/T
         DO 4 J = KP1, N
            T = A(M,J)
            A(M,J) = A(K,J)
            A(K,J) = T
            IF(T .EQ. 0.E0) GO TO 4
            DO 3 I = KP1, N
 3             A(I,J) = A(I,J) + A(I,K)*T
 4       CONTINUE
 5       IF(A(K,K) .EQ. 0.E0) IP(N) = 0
 6    CONTINUE
      RETURN
      END

      SUBROUTINE SOLVER(N,NDIM,A,B,IP)
      REAL A(NDIM,NDIM), B(NDIM), T
      INTEGER IP(NDIM)
C     SOLUTION OF LINEAR SYSTEM, A*X = B.
C     N = ORDER OF MATRIX.
C     NDIM = DECLARED DIMENSION OF THE ARRAY A.
C     B = RIGHT HAND SIDE VECTOR.
C     IP = PIVOT VECTOR OBTAINED FROM SUBROUTINE DECOMP.
C     B = SOLUTION VECTOR, X.

      IF(N.EQ.1) GOTO 9
      NM1 = N - 1
      DO 7 K = 1, NM1
         KP1 = K + 1
         M = IP(K)
         T = B(M)
         B(M) = B(K)
         B(K) = T
         DO 7 I = KP1, N
 7          B(I) = B(I) + A(I,K)*T

      DO 8 KB = 1, NM1
         KM1 = N - KB
         K = KM1 + 1
         B(K) = B(K)/A(K,K)
         T = -B(K)
         DO 8 I = 1, KM1
 8          B(I) = B(I) + A(I,K)*T
 9    B(1) = B(1)/A(1,1)
      RETURN
      END

      SUBROUTINE MATRX(A,N,G)

C     MATRX IS A MATRIX REDUCER OF THE GAUSSIAN TYPE
C     A(I,J) IS THE MATRIX, A(I,N) IS THE RHS VECTOR
C     AND G(I) IS THE SOLUTION VECTOR.

      REAL A(400,400),TEMP(400,400),G(400)

C     INITIALIZE THE G VECTOR TO ALL ZEROES
      DO I=1,N-1
         G(I)=0
      END DO

C     CONVERT COEFFICIENT MATRIX TO
C     UPPER TRIANGULAR FORM
      DO I=1,N-1
 5       IF(ABS(A(I,I)).LT.0.0000001) GOTO 9

         P=A(I,I)
         DO J=I,N
            A(I,J)=A(I,J)/P
         END DO

         DO K=I+1,N-1
            P2=A(K,I)
            DO L=I,N
               A(K,L)=A(K,L)-P2*A(I,L)
            END DO
         END DO
      END DO

C     BACK SUBSTITUTE TRIANGULARIZED MATRIX TO GET
C     VALUES OF SOLUTION VECTOR
      DO I=N-1,1,-1
         G(I)=A(I,N)
         DO J=1,N-1
            A(I,I)=0
            G(I)=G(I)-A(I,J)*G(J)
         END DO
      END DO
      RETURN

C     ORDER MATRIX SO THAT DIAGONAL COEFFICIENTS ARE
C     NOT =0 AND STOP IS MATRIX IS SINGULAR
 9    IF(I.NE.N-1) THEN
         DO J=1,N
            TEMP(I,J)=A(I,J)
            A(I,J)=A(I+1,J)
            A(I+1,J)=TEMP(I,J)
         END DO
         GOTO 5
      ELSE
         GOTO 10
      END IF

 10   WRITE(6,*) 'NO SOLUTION'
      STOP
      END


!> 计算校正平均速度的子程序。详见 Monaghan(1992) (XSPH) 和第 4 章中的论述。
!> subroutine to calculate the average velocity to correct velocity
!> for preventing.penetration (Monaghan, 1992)
subroutine av_vel(ntotal, mass, niac, pair_i, pair_j, w, vx, rho, av)

    use sph_kind, only: rk
    use parameter
    implicit none

    !> 在模拟中所使用的粒子总数
    !> number of particles in simulation
    integer, intent(in) :: ntotal
    !> 粒子的质量
    !> particle masses
    real(rk) :: mass(maxn)
    !> 相互作用对的数目
    !> number of interaction pairs
    integer, intent(in) :: niac
    !> 相互作用对的第一部分的列表
    !> list of first partner of interaction pair
    integer, intent(in) :: pair_i(max_interaction)
    !> 相互作用对的第二部分的列表
    !> list of second partner of interaction pair
    integer, intent(in) :: pair_j(max_interaction)
    !> 给定相互作用对的光滑核函数
    !> kernel for all interaction pairs
    real(rk), intent(in) :: w(max_interaction)
    !> 粒子的速度
    !> particle velocities
    real(rk), intent(in) :: vx(dim, maxn)
    !> 粒子的密度
    !> particle densities
    real(rk), intent(in) :: rho(maxn)
    !> 粒子的平均速度
    !> average velocity of each particle
    real(rk), intent(out) :: av(dim, maxn)

    integer :: i, j, k, d
    real(rk) :: vcc, dvx(dim), epsilon

    ! epsilon -- 经验性的容差值，可能会导致不稳定
    ! 例如，一维震荡管问题，e (epsilon) <= 0.3
    !     epsilon --- a small constants chosen by experience, may lead to instability.
    !     for example, for the 1 dimensional shock tube problem, the e <= 0.3

    epsilon = 0.3_rk

    do i = 1, ntotal
        do d = 1, dim
            av(d, i) = 0.0_rk
        end do
    end do

    do k = 1, niac
        i = pair_i(k)
        j = pair_j(k)
        do d = 1, dim
            dvx(d) = vx(d, i) - vx(d, j)
            av(d, i) = av(d, i) - 2*mass(j)*dvx(d)/(rho(i) + rho(j))*w(k)
            av(d, j) = av(d, j) + 2*mass(i)*dvx(d)/(rho(i) + rho(j))*w(k)
        end do
    end do

    do i = 1, ntotal
        do d = 1, dim
            av(d, i) = epsilon*av(d, i)
        end do
    end do

end subroutine av_vel