! { dg-do run }
! { dg-options "-fbounds-check" }
program main
  real, dimension(2,2) :: result
  real, dimension(6) :: source
  real, dimension(2) :: pad

  call random_number (source)
  call random_number (pad)

  result = reshape(source, shape(result),pad=pad(1:0))
  result = reshape(source, shape(result))
  result = reshape(source, shape(result),pad=pad)

end program main


program l7
    use pyplot_module, only : pyplot
    use functions

    implicit none

    type(pyplot) :: plt

    ! Variables
    integer, parameter :: nx = 31, ny = 31, nt = 50, c = 1
    real(kind=8), parameter :: dx = real(2) / (nx -1 )
    real(kind=8), parameter :: dy = real(2) / (ny -1 )
    real(kind=8), parameter :: sigma = 0.25, nu = 0.05
    real(kind=8), parameter :: dt = sigma * dx * dy / nu
    real(kind=8), dimension(nx,ny) :: u, un
    real(kind=8), dimension(nx) :: x
    real(kind=8), dimension(ny) :: y
    integer :: i, j, n, time, istat
    character :: input
    real(kind=8) :: plotX = 2, plotY = 2

    real(kind=8) :: Ydisip, Xdisip, Yderiv, Xderiv

10  format (i1)
15  format (f10.5,",")
20  format ("")

    !Generate values for y
    call spaceevenly(1, ny, plotY, y)
    !Generate values for x
    call spaceevenly(1, nx, plotX , x)

    ! Generate ones for entire array "u" un"
    do i=1,nx
        do j=1, ny
            u(i,j) = 1
            un(i,j) = 1
        end do
    end do

    ! Set boundary conditions for "u"
    do i=1,nx
        do j=1, ny
            if (i >= 0.5 / dx  .and. i <= 1 / dx + 1 .and. &
                j >= 0.5 / dy .and. j <= 1 / dy + 1) then
                u(i,j) = 2
            end if
        end do
    end do

    ! Main loop
    time = 50
    call diffuse(time, u, nu, dt, dx, dy, nx, ny)

    ! Write to csv
    open(unit=1, file="l7.csv")
    do i=1, nx
        do j=1, ny
            write(unit=1, fmt=15, advance="no"), u(i,j)
        end do
        write(unit=1,fmt=20)
    end do

    print*, "File written"

    call plt%initialize(grid=.true.,&
                        title='Plot of u',legend=.false.,mplot3d=.true.,use_colormap=.true.)

    call plt%plot_surface(x,y,u,label='value of u', istat=istat, &
                            cmap="cm.cividis")

    call plt%savefig('l7.png', &
                      pyfile='l7.py', &
                      dpi='200',istat=istat)

    print*, "Plotting done "
    close(unit=1)
    !read*, input

end program l7


      program DRSIVA
c>> 2010-06-09 DRSIVA  Krogh Used parameters for all dimenssions.
c>> 2001-05-25 DRSIVA  Krogh Minor change for making .f90 version.
c>> 1996-06-14 DRSIVA  Krogh  Small change in output format
c>> 1994-11-02 DRSIVA  Krogh  Changes to use M77CON
c>> 1994-07-18 DRSIVA  Krogh   Last change.
c--S replaces "?": DR?IVA, ?IVA, ?IVAF, ?IVAO
c Sample driver for SIVA --  Set up to solve two second order equations.
c
      integer INEQ, IFDIM, IKDIM, ITDIM, IYDIM
      parameter (INEQ=2,IFDIM=16*INEQ+1,IKDIM=6,ITDIM=4,IYDIM=4*INEQ)
      integer          NEQ, KORD(IKDIM), IOPT(6)
c--S Next line special: P=>D, X=>Q
      real             TSPECS(ITDIM), Y(IYDIM), T, H, DELT, TFINAL
      integer NDIG
      real             F(IFDIM), TOL
      equivalence (TSPECS(1), T), (TSPECS(2), H), (TSPECS(3), DELT),
     1  (TSPECS(4), TFINAL)
      external SIVAO, SIVAF
c++SP Default NDIG = 4
c++  Default NDIG = 10
c++ Substitute for NDIG below
      parameter (NDIG = 4 )
      parameter (TOL = 10.E0 **(-NDIG))
c
      data   NEQ,    T,    H,                   DELT, TFINAL /
     1         2, 0.E0, 1.E0, 6.283185307179586477E0,   2.E1 /,
     2       Y(1), Y(2), Y(3), Y(4) /
     3       1.E0, 0.E0, 0.E0, 1.E0 /
c
c Set option for error control, local absolute error < TOL.
      data   IOPT(1), IOPT(2), IOPT(3) /
     1            16,       6,   3 /,
c Group the system to be treated as a single unit, set tolerance value
     2                KORD(6), F(3)/
     3                      2,  TOL/
c Set option for second order equations
      data   IOPT(4), IOPT(5) /
     1            17,       2 /
c  Flag end of options
      data   IOPT(6) / 0/
c
c Do the integration
c
      KORD(1) = 0
  100 continue
      call SIVA(TSPECS, Y, F, KORD, NEQ, SIVAF, SIVAO,
     1  ITDIM, IYDIM, IFDIM, IKDIM, IOPT)
      if (KORD(1) .NE. 1) go to 100
      stop
      end

      subroutine SIVAF(T, Y, F, KORD)
c Sample derivative subroutine for use with SIVA
c This evaluates derivatives for a simple two body problem.
c
      integer          KORD
c--S Next line special: P=>D, X=>Q
      real             T, Y(4), TP
      real             F(2)
c
c Evaluate the derivatives
c
      TP = Y(1)*Y(1) + Y(3)*Y(3)
      TP = 1.E0 / (TP * SQRT(TP))
      F(1) = -Y(1) * TP
      F(2) = -Y(3) * TP
      return
      end

      subroutine SIVAO(TSPECS, Y, F, KORD)
c Sample output subroutine for use with SIVA.
c This subroutine gives output for a simple two body problem.
c
      integer          KORD
c--S Next line special: P=>D, X=>Q
      real             TSPECS(4), Y(4)
      real             F(2)
 1000 format (12X,
     1   'RESULTS FOR A SIMPLE 2-BODY PROBLEM'//
     2   8X, 'T', 13X, 'U/V', 11X, 'UP/VP', 9X, 'UPP/VPP')
 1001 format (1P,SP,4E15.6 / 15X, 3E15.6/' ')
c
c Do the output
c
      if (KORD .EQ. 1) then
        write (*, 1000)
      end if
      write (*, 1001) TSPECS(1), Y(1), Y(2), F(1), Y(3), Y(4), F(2)
c
      return
      end


      SUBROUTINE TG01LY( COMPQ, COMPZ, N, M, P, RANKE, RNKA22, A, LDA,
     $                   E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NF,
     $                   NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal transformation matrices Q and Z which reduce
C     the regular pole pencil A-lambda*E of the descriptor system
C     (A-lambda*E,B,C), with the A and E matrices in the form
C
C           ( A11 A12 A13 )             ( E11  0  0 )
C       A = ( A21 A22 A23 ) ,       E = (  0   0  0 ) ,              (1)
C           ( A31  0   0  )             (  0   0  0 )
C
C     where E11 and A22 are nonsingular and upper triangular matrices,
C     to the form
C
C                ( Af  *  )             ( Ef  *  )
C       Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ,
C                ( 0   Ai )             ( 0   Ei )
C
C     where the subpencil Af-lambda*Ef contains the finite eigenvalues
C     and the subpencil Ai-lambda*Ei contains the infinite eigenvalues.
C     The subpencil Ai-lambda*Ei is in a staircase form with the
C     matrices Ai and Ei of form
C
C
C           ( A0,0  A0,k ... A0,1 )         ( 0  E0,k ... E0,1 )
C      Ai = (  0    Ak,k ... Ak,1 ) ,  Ei = ( 0   0   ... Ek,1 ) ,   (2)
C           (  :     :   ...   :  )         ( :   :   ...   :  )
C           (  0     0   ... A1,1 )         ( 0   0   ...   0  )
C
C     where Ai,i, for i = 0, 1, ..., k, are nonsingular upper triangular
C     matrices.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   LOGICAL
C             Specify the option to accumulate or not the performed
C             left transformations:
C             COMPQ = .FALSE. : do not accumulate the transformations;
C             COMPQ = .TRUE.  : accumulate the transformations; in this
C                     case, Q must contain an orthogonal matrix Q1
C                     on entry, and the product Q1*Q is returned.
C
C     COMPZ   LOGICAL
C             Specify the option to accumulate or not the performed
C             right transformations:
C             COMPZ = .FALSE. : do not accumulate the transformations;
C             COMPZ = .TRUE.  : accumulate the transformations; in this
C                     case, Z must contain an orthogonal matrix Z1
C                     on entry, and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix B, the number of columns
C             of the matrix C and the order of the square matrices A
C             and E.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrix C.  P >= 0.
C
C     RANKE   (input) INTEGER
C             The rank of the matrix E; also, the order of the upper
C             triangular matrix E11.  0 <= RANKE <= N.
C
C     RNKA22  (input) DOUBLE PRECISION
C             The order of the nonsingular submatrix A22 of A.
C             0 <= RNKA22 <= N - RANKE.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N state matrix A in the form (1).
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Q'*A*Z,
C
C                                ( Af  *  )
C                       Q'*A*Z = (        ) ,
C                                ( 0   Ai )
C
C             where Af is NF-by-NF and Ai is (N-NF)-by-(N-NF).
C             The submatrix Ai is in the staircase form (2), where A0,0
C             is (N-RANKE)-by-(N-RANKE), and Ai,i , for i = 1, ...,
C             NIBLCK is IBLCK(i)-by-IBLCK(i).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N descriptor matrix E in the form (1).
C             On exit, the leading N-by-N part of this array contains
C             the transformed descriptor matrix Q'*E*Z,
C
C                                ( Ef  *  )
C                       Q'*E*Z = (        ) ,
C                                ( 0   Ei )
C
C             where Ef is an NF-by-NF nonsingular matrix and Ei is an
C             (N-NF)-by-(N-NF) nilpotent matrix in the staircase
C             form (2).
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the N-by-M input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If COMPQ = .FALSE., Q is not referenced.
C             If COMPQ = .TRUE., on entry, the leading N-by-N part of
C                         this array must contain an orthogonal matrix
C                         Q1; on exit, the leading N-by-N part of this
C                         array contains the orthogonal matrix Q1*Q.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,        if COMPQ = .FALSE.;
C             LDQ >= MAX(1,N), if COMPQ = .TRUE. .
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = .FALSE., Z is not referenced.
C             If COMPZ = .TRUE., on entry, the leading N-by-N part of
C                        this array must contain an orthogonal matrix
C                        Z1; on exit, the leading N-by-N part of this
C                        array contains the orthogonal matrix Z1*Z.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.
C             LDZ >= 1,        if COMPZ = .FALSE.;
C             LDZ >= MAX(1,N), if COMPZ = .TRUE. .
C
C     NF      (output) INTEGER
C             The order of the reduced matrices Af and Ef; also, the
C             number of finite generalized eigenvalues of the pencil
C             A-lambda*E.
C
C     NIBLCK  (output) INTEGER
C             If RANKE < N, the number of infinite blocks minus one.
C             If RANKE = N, NIBLCK = 0.
C
C     IBLCK   (output) INTEGER array, dimension (N)
C             IBLCK(i) contains the dimension of the i-th block in the
C             staircase form (2), where i = 1, 2, ..., NIBLCK.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR factorization with column pivoting whose estimated
C             condition number is less than 1/TOL.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             TOLDEF = N**2*EPS,  is used instead, where EPS is the
C             machine precision (see LAPACK Library routine DLAMCH).
C             TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N-RANKE)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1, if RANKE = N; otherwise,
C             LDWORK >= MAX(4*(N-RANKE)-1, N-RANKE-RNKA22+MAX(N,M)).
C             For optimal performance, LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the pencil A-lambda*E is not regular.
C
C     METHOD
C
C     The subroutine is based on the reduction algorithm of [1].
C
C     REFERENCES
C
C     [1] Misra, P., Van Dooren, P., and Varga, A.
C         Computation of structural invariants of generalized
C         state-space systems.
C         Automatica, 30, pp. 1921-1936, 1994.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N**3 )  floating point operations.
C
C     FURTHER COMMENTS
C
C     The number of infinite poles is computed as
C
C            NIBLCK
C             Sum  IBLCK(i) = RANKE - NF.
C             i=1
C
C     The multiplicities of infinite poles can be computed as follows:
C     there are IBLCK(k)-IBLCK(k+1) infinite poles of multiplicity
C     k, for k = 1, ..., NIBLCK, where IBLCK(NIBLCK+1) = 0.
C     Note that each infinite pole of multiplicity k corresponds to
C     an infinite eigenvalue of multiplicity k+1.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     July 1999. Based on the RASP routine SRISEP.
C
C     REVISIONS
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     July 2001; Nov. 2002
C     V. Sima, Dec. 2016, Feb. 2017, June 2017.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, system poles, multivariable
C     system, orthogonal transformation, structural invariant.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      LOGICAL            COMPQ, COMPZ
      INTEGER            INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M,
     $                   N, NF, NIBLCK, P, RANKE, RNKA22
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IBLCK( * ), IWORK(*)
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK(  * ), E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            FIRST, LQUERY
      INTEGER            I, I0, I1, ICOL, IPIV, IROW, ITAU, J, JWORK1,
     $                   JWORK2, K, MINWRK, MM1, N1, ND, NR, RANK, RO,
     $                   RO1, SIGMA, WRKOPT
      DOUBLE PRECISION   CO, RCOND, SI, SVLMAX, T, TOLDEF
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1), SVAL(3)
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANTR, DLAPY2, DNRM2
      EXTERNAL           DLAMCH, DLANGE, DLANTR, DLAPY2, DNRM2
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DLAPMT, DLARFG, DLARTG, DLASET,
     $                   DLATZM, DORMQR, DROT, DSWAP, DTRCON, MB03OY,
     $                   XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MIN, MOD
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( RANKE.LT.0 .OR. RANKE.GT.N ) THEN
         INFO = -6
      ELSE IF( RNKA22.LT.0 .OR. RNKA22+RANKE.GT.N ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( ( COMPQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -17
      ELSE IF( ( COMPZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -19
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -23
      ELSE
         LQUERY = ( LDWORK.EQ.-1 )
C
         ND  = N  - RANKE
         RO1 = ND
         IF( RANKE.EQ.N ) THEN
            MINWRK = 1
         ELSE
            MINWRK = MAX( 4*ND - 1, RO1 + MAX( N, M ) )
         END IF
         IF( LQUERY ) THEN
            CALL DORMQR( 'Left', 'Transpose', RO1, RANKE, ND,
     $                   A, LDA, DWORK, A, LDA, DWORK, -1, INFO )
            WRKOPT = MAX( MINWRK, INT( DWORK(1) ) + ND )
            CALL DORMQR( 'Left', 'Transpose', RO1, M, ND, A, LDA,
     $                   DWORK, B, LDB, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + ND )
            IF( COMPQ ) THEN
               CALL DORMQR( 'Right', 'No-Transpose', N, RO1, ND, A,
     $                      LDA, DWORK, Q, LDQ, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + ND )
            END IF
         ELSE IF( LDWORK.LT.MINWRK ) THEN
            INFO = -26
         END IF
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01LY', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Initialize output variables.
C
      NF = RANKE
      NIBLCK = 0
C
C     Quick return if possible.
C
      IF( RANKE.EQ.N ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Trivial rank check.
C
      IF( RANKE.EQ.0 .AND. RNKA22.EQ.0 ) THEN
         INFO = 1
         RETURN
      END IF
C
C     Skip reduction if A22 has rank N-RANKE.
C
      WRKOPT = MINWRK
      IF( RNKA22.EQ.ND )
     $   GO TO 110
C
      TOLDEF = TOL
      IF( TOLDEF.LE.ZERO ) THEN
C
C        Use the default tolerance in rank determination.
C
         TOLDEF = DBLE( N*N ) * DLAMCH( 'Precision' )
      END IF
C
C     Permute block columns to put E in the form  E = ( 0 E1 )
C                                                     ( 0 0  )
C
C     and define accordingly  A = ( B1 A1 ).
C                                 ( D1 C1 )
C
      MM1 = ND + 1
      CALL DLACPY( 'Full', N, ND, A(1,RANKE+1), LDA, E(1,RANKE+1), LDE )
      IF( RANKE.LE.ND ) THEN
         CALL DLACPY( 'Full', N, RANKE, A, LDA, A(1,MM1), LDA )
      ELSE
         K = MOD( RANKE, ND )
         DO 10 I = N-2*ND+1, K+1, -ND
            CALL DLACPY( 'Full', N, ND, A(1,I), LDA, A(1,I+ND), LDA )
   10    CONTINUE
         IF( K.NE.0 )
     $      CALL DLACPY( 'Full', N, K, A, LDA, A(1,MM1), LDA )
      END IF
      CALL DLACPY( 'Full', N, ND, E(1,RANKE+1), LDE, A, LDA )
      IF( COMPZ ) THEN
         CALL DLACPY( 'Full', N, ND, Z(1,RANKE+1), LDZ, E(1,RANKE+1),
     $                LDE )
         IF( RANKE.LE.ND ) THEN
            CALL DLACPY( 'Full', N, RANKE, Z, LDZ, Z(1,MM1), LDZ )
         ELSE
            DO 20 I = N-2*ND+1, K+1, -ND
               CALL DLACPY( 'Full', N, ND, Z(1,I), LDZ, Z(1,I+ND), LDZ )
   20       CONTINUE
            IF( K.NE.0 )
     $         CALL DLACPY( 'Full', N, K, Z, LDZ, Z(1,MM1), LDZ )
         END IF
         CALL DLACPY( 'Full', N, ND, E(1,RANKE+1), LDE, Z, LDZ )
      END IF
      IF( P.LE.N ) THEN
         CALL DLACPY( 'Full', P, ND, C(1,RANKE+1), LDC, E(1,RANKE+1),
     $                LDE )
         IF( RANKE.LE.ND ) THEN
            CALL DLACPY( 'Full', P, RANKE, C, LDC, C(1,MM1), LDC )
         ELSE
            DO 30 I = N-2*ND+1, K+1, -ND
               CALL DLACPY( 'Full', P, ND, C(1,I), LDC, C(1,I+ND), LDC )
   30       CONTINUE
            IF( K.NE.0 )
     $         CALL DLACPY( 'Full', P, K, C, LDC, C(1,MM1), LDC )
         END IF
         CALL DLACPY( 'Full', P, ND, E(1,RANKE+1), LDE, C, LDC )
      ELSE
         DO 40 I = 1, P
            CALL DCOPY( ND, C(I,RANKE+1), LDC, DWORK, 1 )
            CALL DCOPY( RANKE, C(I,1), LDC, DWORK(ND+1), 1 )
            CALL DCOPY( N, DWORK, 1, C(I,1), LDC )
   40    CONTINUE
      END IF
      IF( RANKE.LE.ND ) THEN
         CALL DLACPY( 'Full', N, RANKE, E, LDE, E(1,MM1), LDE )
      ELSE
         DO 50 I = N-2*ND+1, K+1, -ND
            CALL DLACPY( 'Full', N, ND, E(1,I), LDE, E(1,I+ND), LDE )
   50    CONTINUE
         IF( K.NE.0 )
     $      CALL DLACPY( 'Full', N, K, E, LDE, E(1,MM1), LDE )
      END IF
      CALL DLASET( 'Full', N, ND, ZERO, ZERO, E, LDE )
C
C     Set the estimate of the maximum singular value of A to ||A||_F.
C
      SVAL(1) = DLANGE( 'Frobenius', RANKE, RNKA22, A, LDA, DWORK )
      SVAL(2) = DLANTR( 'Frobenius', 'Upper', 'Non-Unit', RNKA22,
     $                  RNKA22, A(RANKE+1,1), LDA, DWORK )
      SVAL(3) = DLANGE( 'Frobenius', RANKE+RNKA22, ND-RNKA22,
     $                  A(1,RNKA22+1), LDA, DWORK )
      SVLMAX  = DLAPY2( DNRM2( 3, SVAL, 1 ),
     $                  DLANGE( 'Frobenius', N, RANKE, A(1,ND+1), LDA,
     $                          DWORK ) )/DBLE( N )
C
C     The D1 matrix is (RO+SIGMA)-by-(RO+SIGMA), where RO = ND - SIGMA
C     and SIGMA = 0. At each iteration the leading (RO+SIGMA)-by-SIGMA
C     submatrix of D1 has full column rank, with the trailing
C     SIGMA-by-SIGMA submatrix upper triangular.
C
      RO = ND
C
      SIGMA  = 0
      FIRST  = .TRUE.
      ITAU   = 1
      JWORK1 = ITAU   + ND
      JWORK2 = JWORK1 + 1
      DUM(1) = ZERO
C
   60 CONTINUE
      IF( FIRST ) THEN
         RO1 = ND - RNKA22
      ELSE
C
C        (NF+1,1) points to the current position of matrix D1.
C
         RO1 = RO
C
C        Compress columns of D1; first exploit the trapezoidal shape of
C        the (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D1;
C        compress the first SIGMA columns without column pivoting:
C
C              ( x x x x x )       ( x x x x x )
C              ( x x x x x )       ( 0 x x x x )
C              ( x x x x x )  - >  ( 0 0 x x x )
C              ( 0 x x x x )       ( 0 0 0 x x )
C              ( 0 0 x x x )       ( 0 0 0 x x )
C
C        where SIGMA = 3 and RO = 2.
C        Workspace: need  MAX( N, M ).
C
         IROW = NF
         DO 70 ICOL = 1, SIGMA
            IROW = IROW + 1
            CALL DLARFG( RO+1, A(IROW,ICOL), A(IROW+1,ICOL), 1, T )
            CALL DLATZM( 'L', RO+1, N-ICOL, A(IROW+1,ICOL), 1, T,
     $                   A(IROW,ICOL+1), A(IROW+1,ICOL+1), LDA, DWORK )
            CALL DLATZM( 'L', RO+1, RANKE, A(IROW+1,ICOL), 1, T,
     $                   E(IROW,ND+1), E(IROW+1,ND+1), LDE, DWORK )
            IF( COMPQ )
     $         CALL DLATZM( 'R', N, RO+1, A(IROW+1,ICOL), 1, T,
     $                      Q(1, IROW), Q(1, IROW+1), LDQ, DWORK )
            CALL DLATZM( 'L', RO+1, M, A(IROW+1,ICOL), 1, T,
     $                   B(IROW,1), B(IROW+1,1), LDB, DWORK )
            CALL DCOPY( ND-ICOL, DUM, 0, A(IROW+1, ICOL), 1 )
   70    CONTINUE
C
C        Continue with Householder with column pivoting.
C
C              ( x x x x x )       ( x x x x x )
C              ( 0 x x x x )       ( 0 x x x x )
C              ( 0 0 x x x )  ->   ( 0 0 x x x ) .
C              ( 0 0 0 x x )       ( 0 0 0 x x )
C              ( 0 0 0 x x )       ( 0 0 0 0 0 )
C
C                             ( D11 D12 )
C        Reduce further D1 to (  0  D22 ), where D22 is full
C                             (  0   0  )
C        row rank upper triangular.
C        Real workspace:    need  4*ND - 1;
C        Integer workspace: need  ND.
C
         IROW = MIN( NF+SIGMA+1, N  )
         ICOL = MIN(    SIGMA+1, ND )
         CALL MB03OY( RO1, ND-SIGMA, A(IROW,ICOL), LDA, TOLDEF, SVLMAX,
     $                RANK, SVAL, IWORK, DWORK(ITAU), DWORK(JWORK1),
     $                INFO )
C
C        Apply the column permutations to D12 and to the corresponding
C        columns of B1.
C
         CALL DLAPMT( .TRUE., NF+SIGMA, ND-SIGMA, A(1,ICOL), LDA,
     $                IWORK )
         CALL DLAPMT( .TRUE., P, ND-SIGMA, C(1,ICOL), LDC, IWORK )
         IF( COMPZ )
     $      CALL DLAPMT( .TRUE., N, ND-SIGMA, Z(1,ICOL), LDZ, IWORK )
C
         IF( RANK.GT.0 ) THEN
C
C           Apply the Householder transformations to the submatrix C1
C                                            ( C11 )
C           and define the transformed C1 as ( C21 ).
C                                            ( C31 )
C           Workspace: need    RANK + MAX(N,M);
C                      prefer  RANK + MAX(N,M)*NB.
C
            CALL DORMQR( 'Left', 'Transpose', RO1, RANKE, RANK,
     $                   A(IROW,ICOL), LDA, DWORK(ITAU), A(IROW,MM1),
     $                   LDA, DWORK(JWORK1), LDWORK-JWORK1+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK1) ) + JWORK1 - 1 )
            CALL DORMQR( 'Left', 'Transpose', RO1, M, RANK,
     $                   A(IROW,ICOL), LDA, DWORK(ITAU), B(IROW,1), LDB,
     $                   DWORK(JWORK1), LDWORK-JWORK1+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK1) ) + JWORK1 - 1 )
            CALL DORMQR( 'Left', 'Transpose', RO1, RANKE, RANK,
     $                   A(IROW,ICOL), LDA, DWORK(ITAU), E(IROW,MM1),
     $                   LDE, DWORK(JWORK1), LDWORK-JWORK1+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK1) ) + JWORK1 - 1 )
            IF( COMPQ ) THEN
               CALL DORMQR( 'Right', 'No-Transpose', N, RO1, RANK,
     $                      A(IROW,ICOL), LDA, DWORK(ITAU), Q(1,IROW),
     $                      LDQ, DWORK(JWORK1), LDWORK-JWORK1+1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK1) ) + JWORK1 - 1 )
            END IF
            CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO,
     $                   ZERO, A(MIN( IROW+1, N ),ICOL), LDA )
            RO1 = RO1 - RANK
         END IF
      END IF
C
C     Terminate if D1 has maximal row rank.
C
      IF( RO1.GT.0 ) THEN
C
C        Update SIGMA and number of blocks.
C
         SIGMA  = ND - RO1
         NIBLCK = NIBLCK + 1
C
C        Compress the columns of current C31 to separate a RO1-by-RO1
C        invertible block.
C        Perform RQ-decomposition on the current C31 while keeping E1
C        upper triangular. No row pivoting is necessary since the
C        pencil is assumed regular. Still check regularity at first
C        iteration.
C        The current C31 is the RO1-by-NF matrix delimited by rows
C        NF+SIGMA+1 to NF+SIGMA+RO1 and columns ND+1 to ND+NF of A1.
C        The rank of current C21 is checked only for the first iteration.
C
C        IPIV will point to the current pivot position in C31.
C
         IPIV = NF + ND + 1
         N1   = NF + 1
         DO 90 I = 1, RO1
            IPIV = IPIV - 1
            N1   = N1   - 1
C
C           Zero elements left to A(IPIV,IPIV).
C
            DO 80 K = 1, N1-1
               J = ND + K
C
C              Rotate columns J, J+1 to zero A(IPIV,J).
C
               T = A(IPIV,J+1)
               CALL DLARTG( T, A(IPIV,J), CO, SI, A(IPIV,J+1) )
               A(IPIV,J) = ZERO
               CALL DROT( IPIV-1, A(1,J+1), 1, A(1,J), 1, CO, SI )
               CALL DROT( K+1, E(1,J+1), 1, E(1,J), 1, CO, SI )
               CALL DROT( P, C(1,J+1), 1, C(1,J), 1, CO, SI )
               IF( COMPZ )
     $            CALL DROT( N, Z(1,J+1), 1, Z(1,J), 1, CO, SI )
C
C              Rotate rows K, K+1 to zero E(K+1,J).
C
               T = E(K,J)
               CALL DLARTG( T, E(K+1,J), CO, SI, E(K,J) )
               E(K+1,J) = ZERO
               CALL DROT( N-J, E(K,J+1), LDE, E(K+1,J+1), LDE, CO, SI )
               CALL DROT( N, A(K,1), LDA, A(K+1,1), LDA, CO, SI )
               CALL DROT( M, B(K,1), LDB, B(K+1,1), LDB, CO, SI )
               IF( COMPQ )
     $            CALL DROT( N, Q(1,K), 1, Q(1,K+1), 1, CO, SI )
   80       CONTINUE
C
   90    CONTINUE
C
C        Check regularity of the pencil.
C        Real workspace:    need 3*RO1.
C        Integer workspace: need RO1.
C
         IF( DLANTR( 'Frobenius', 'Upper', 'Non-Unit', RO1, RO1,
     $                A(IPIV,IPIV), LDA, DWORK ) .LE. TOLDEF*SVLMAX )
     $         THEN
            INFO = 1
         ELSE
            CALL DTRCON( '1-norm', 'Upper', 'Non-unit', RO1,
     $                    A(IPIV,IPIV), LDA, RCOND, DWORK, IWORK, INFO )
            IF( RCOND.LE.TOLDEF )
     $         INFO = 1
         END IF
C
C        Return with error for non-regular system.
C
         IF( INFO.NE.0 )
     $      RETURN
C
         NF = NF - RO1
C
C        Set the order of i-th block.
C
         IBLCK(NIBLCK) = RO1
         RO = RO1
         FIRST = .FALSE.
C
         GO TO 60
      END IF
C
      IF( NF.GT.0 ) THEN
C
C        Permute block columns to put A and E in the form
C
C               ( A1 B1  *  )       ( E1 0  *  )
C           A = ( C1 D1  *  ),  E = ( 0  0  *  ) .
C               ( 0   0  Ai )       ( 0  0  Ei )
C
         NR = NF + ND
         DUM(1) = ZERO
         CALL DLACPY( 'Full', NR, ND, A, LDA, E, LDE )
         CALL DLACPY( 'Full', NR, NF, A(1,ND+1), LDA, A, LDA )
         CALL DLACPY( 'Full', NR, ND, E, LDE, A(1,NF+1), LDA )
         IF( COMPZ ) THEN
            CALL DLACPY( 'Full', N, ND, Z, LDZ, E, LDE )
            CALL DLACPY( 'Full', N, NF, Z(1,ND+1), LDZ, Z, LDZ )
            CALL DLACPY( 'Full', N, ND, E, LDE, Z(1,NF+1), LDZ )
         END IF
         IF( P.LE.N ) THEN
            CALL DLACPY( 'Full', P, ND, C, LDC, E, LDE )
            CALL DLACPY( 'Full', P, NF, C(1,ND+1), LDC, C, LDC )
            CALL DLACPY( 'Full', P, ND, E, LDE, C(1,NF+1), LDC )
         ELSE
            DO 100 I = 1, P
               CALL DCOPY( ND, C(I,1), LDC, DWORK, 1 )
               CALL DCOPY( NF, C(I,ND+1), LDC, C(I,1), LDC )
               CALL DCOPY( ND, DWORK, 1, C(I,NF+1), LDC )
  100       CONTINUE
         END IF
         CALL DLACPY( 'Full', N, NF, E(1,ND+1), LDE, E, LDE )
         CALL DLASET( 'Full', N, ND, ZERO, ZERO, E(1,NF+1), LDE )
         CALL DLASET( 'Full', N-NF-ND, NF+ND, ZERO, ZERO,
     $                A(NF+ND+1,1), LDA )
      END IF
C
C     Annihilate C1 keeping E upper triangular, to obtain
C
C             ( Af  *    *  )       ( Ef *  *  )
C         A = ( 0  A0,0  *  ),  E = ( 0  0  *  ) .
C             ( 0   0    Ai )       ( 0  0  Ei )
C
  110 CONTINUE
      I1 = NF + ND
      DO 130 I0 = ND, 1, -1
C
C        Annihilate elements A(I1,1), ..., A(I1,NF) using A(I1,I1)
C        as pivot element; E remains further upper triangular.
C
         K = 1
         DO 120 J = 1, NF
C
C           Rotate columns I1 and J to zero A(I1,J).
C
            T = A(I1,I1)
            CALL DLARTG( T, A(I1,J), CO, SI, A(I1,I1) )
            A(I1,J) = ZERO
            CALL DROT( I1-1, A(1,I1), 1, A(1,J), 1, CO, SI )
            CALL DROT( K, E(1,I1), 1, E(1,J), 1, CO, SI )
            CALL DROT( P, C(1,I1), 1, C(1,J), 1, CO, SI )
            IF( COMPZ )
     $         CALL DROT( N, Z(1,I1), 1, Z(1,J), 1, CO, SI )
            K = K + 1
  120    CONTINUE
         I1 = I1 - 1
  130 CONTINUE
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of TG01LY ***
      END


c       this file contains the following user-callable routines:
c
c
c       routine idd_frm transforms a vector via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c
c       routine idd_sfrm transforms a vector into a vector
c       of specified length via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c
c       routine idd_frmi initializes routine idd_frm.
c
c       routine idd_sfrmi initializes routine idd_sfrm.
c
c       routine idd_pairsamps calculates the indices of the pairs
c       of integers to which the individual integers
c       in a specified set belong.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idd_frm(m,n,w,x,y)
c
c       transforms x into y via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c       In contrast to routine idd_sfrm, the present routine works best
c       when the length of the transformed vector is the integer n
c       output by routine idd_frmi, or when the length
c       is not specified, but instead determined a posteriori
c       using the output of the present routine. The transformed vector
c       output by the present routine is randomly permuted.
c
c       input:
c       m -- length of x
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m, as obtained
c            from the routine idd_frmi; n is the length of y
c       w -- initialization array constructed by routine idd_frmi
c       x -- vector to be transformed
c
c       output:
c       y -- transform of x
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,iw,n,k
        real*8 w(17*m+70),x(m),y(n)
c
c
c       Apply Rokhlin's random transformation to x, obtaining
c       w(16*m+71 : 17*m+70).
c
        iw = w(3+m+n)
        call idd_random_transf(x,w(16*m+70+1),w(iw))
c
c
c       Subselect from  w(16*m+71 : 17*m+70)  to obtain y.
c
        call idd_subselect(n,w(3),m,w(16*m+70+1),y)
c
c
c       Copy y into  w(16*m+71 : 16*m+n+70).
c
        do k = 1,n
          w(16*m+70+k) = y(k)
        enddo ! k
c
c
c       Fourier transform  w(16*m+71 : 16*m+n+70).
c
        call dfftf(n,w(16*m+70+1),w(4+m+n))
c
c
c       Permute  w(16*m+71 : 16*m+n+70)  to obtain y.
c
        call idd_permute(n,w(3+m),w(16*m+70+1),y)
c
c
        return
        end
c
c
c
c
        subroutine idd_sfrm(l,m,n,w,x,y)
c
c       transforms x into y via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c       In contrast to routine idd_frm, the present routine works best
c       when the length l of the transformed vector is known a priori.
c
c       input:
c       l -- length of y; l must be less than or equal to n
c       m -- length of x
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m, as obtained
c            from the routine idd_sfrmi
c       w -- initialization array constructed by routine idd_sfrmi
c       x -- vector to be transformed
c
c       output:
c       y -- transform of x
c
c       _N.B._: l must be less than or equal to n.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,iw,n,l,l2
        real*8 w(27*m+90),x(m),y(l)
c
c
c       Retrieve the number of pairs of outputs to be calculated
c       via sfft.
c
        l2 = w(3)
c
c
c       Apply Rokhlin's random transformation to x, obtaining
c       w(25*m+91 : 26*m+90).
c
        iw = w(4+m+l+l2)
        call idd_random_transf(x,w(25*m+90+1),w(iw))
c
c
c       Subselect from  w(25*m+91 : 26*m+90)  to obtain
c       w(26*m+91 : 26*m+n+90).
c
        call idd_subselect(n,w(4),m,w(25*m+90+1),w(26*m+90+1))
c
c
c       Fourier transform  w(26*m+91 : 26*m+n+90).
c
        call idd_sfft(l2,w(4+m+l),n,w(5+m+l+l2),w(26*m+90+1))
c
c
c       Copy the desired entries from  w(26*m+91 : 26*m+n+90)
c       to y.
c
        call idd_subselect(l,w(4+m),n,w(26*m+90+1),y)
c
c
        return
        end
c
c
c
c
        subroutine idd_pairsamps(n,l,ind,l2,ind2,marker)
c
c       calculates the indices of the l2 pairs of integers
c       to which the l individual integers from ind belong.
c       The integers in ind may range from 1 to n.
c
c       input:
c       n -- upper bound on the integers in ind
c            (the number 1 must be a lower bound);
c            n must be even
c       l -- length of ind
c       ind -- integers selected from 1 to n
c
c       output:
c       l2 -- length of ind2
c       ind2 -- indices in the range from 1 to n/2 of the pairs
c               of integers to which the entries of ind belong
c
c       work:
c       marker -- must be at least n/2 integer elements long
c
c       _N.B._: n must be even.
c
        implicit none
        integer l,n,ind(l),ind2(l),marker(n/2),l2,k
c
c
c       Unmark all pairs.
c
        do k = 1,n/2
          marker(k) = 0
        enddo ! k
c
c
c       Mark the required pairs.
c
        do k = 1,l
          marker((ind(k)+1)/2) = marker((ind(k)+1)/2)+1
        enddo ! k
c
c
c       Record the required pairs in indpair.
c
        l2 = 0
c
        do k = 1,n/2
c
          if(marker(k) .ne. 0) then
            l2 = l2+1
            ind2(l2) = k
          endif
c
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idd_permute(n,ind,x,y)
c
c       copy the entries of x into y, rearranged according
c       to the permutation specified by ind.
c
c       input:
c       n -- length of ind, x, and y
c       ind -- permutation of n objects
c       x -- vector to be permuted
c
c       output:
c       y -- permutation of x
c
        implicit none
        integer n,ind(n),k
        real*8 x(n),y(n)
c
c
        do k = 1,n
          y(k) = x(ind(k))
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idd_subselect(n,ind,m,x,y)
c
c       copies into y the entries of x indicated by ind.
c
c       input:
c       n -- number of entries of x to copy into y
c       ind -- indices of the entries in x to copy into y
c       m -- length of x
c       x -- vector whose entries are to be copied
c
c       output:
c       y -- collection of entries of x specified by ind
c
        implicit none
        integer n,ind(n),m,k
        real*8 x(m),y(n)
c
c
        do k = 1,n
          y(k) = x(ind(k))
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idd_frmi(m,n,w)
c
c       initializes data for the routine idd_frm.
c
c       input:
c       m -- length of the vector to be transformed
c
c       output:
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m
c       w -- initialization array to be used by routine idd_frm
c
c
c       glossary for the fully initialized w:
c
c       w(1) = m
c       w(2) = n
c       w(3:2+m) stores a permutation of m objects
c       w(3+m:2+m+n) stores a permutation of n objects
c       w(3+m+n) = address in w of the initialization array
c                  for idd_random_transf
c       w(4+m+n:int(w(3+m+n))-1) stores the initialization array
c                                for dfft
c       w(int(w(3+m+n)):16*m+70) stores the initialization array
c                                for idd_random_transf
c
c
c       _N.B._: n is an output of the present routine;
c               this routine changes n.
c
c
        implicit none
        integer m,n,l,nsteps,keep,lw,ia
        real*8 w(17*m+70)
c
c
c       Find the greatest integer less than or equal to m
c       which is a power of two.
c
        call idd_poweroftwo(m,l,n)
c
c
c       Store m and n in w.
c
        w(1) = m
        w(2) = n
c
c
c       Store random permutations of m and n objects in w.
c
        call id_randperm(m,w(3))
        call id_randperm(n,w(3+m))
c
c
c       Store the address within w of the idd_random_transf_init
c       initialization data.
c
        ia = 4+m+n+2*n+15
        w(3+m+n) = ia
c
c
c       Store the initialization data for dfft in w.
c
        call dffti(n,w(4+m+n))
c
c
c       Store the initialization data for idd_random_transf_init in w.
c
        nsteps = 3
        call idd_random_transf_init(nsteps,m,w(ia),keep)
c
c
c       Calculate the total number of elements used in w.
c
        lw = 3+m+n+2*n+15 + 3*nsteps*m+2*m+m/4+50
c
        if(16*m+70 .lt. lw) then
          !call prinf('lw = *',lw,1)
          !call prinf('16m+70 = *',16*m+70,1)
          stop
        endif
c
c
        return
        end
c
c
c
c
        subroutine idd_sfrmi(l,m,n,w)
c
c       initializes data for the routine idd_sfrm.
c
c       input:
c       l -- length of the transformed (output) vector
c       m -- length of the vector to be transformed
c
c       output:
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m
c       w -- initialization array to be used by routine idd_sfrm
c
c
c       glossary for the fully initialized w:
c
c       w(1) = m
c       w(2) = n
c       w(3) = l2
c       w(4:3+m) stores a permutation of m objects
c       w(4+m:3+m+l) stores the indices of the l outputs which idd_sfft
c                    calculates
c       w(4+m+l:3+m+l+l2) stores the indices of the l2 pairs of outputs
c                         which idd_sfft calculates
c       w(4+m+l+l2) = address in w of the initialization array
c                     for idd_random_transf
c       w(5+m+l+l2:int(w(4+m+l+l2))-1) stores the initialization array
c                                      for idd_sfft
c       w(int(w(4+m+l+l2)):25*m+90) stores the initialization array
c                                   for idd_random_transf
c
c
c       _N.B._: n is an output of the present routine;
c               this routine changes n.
c
c
        implicit none
        integer l,m,n,idummy,nsteps,keep,lw,l2,ia
        real*8 w(27*m+90)
c
c
c       Find the greatest integer less than or equal to m
c       which is a power of two.
c
        call idd_poweroftwo(m,idummy,n)
c
c
c       Store m and n in w.
c
        w(1) = m
        w(2) = n
c
c
c       Store random permutations of m and n objects in w.
c
        call id_randperm(m,w(4))
        call id_randperm(n,w(4+m))
c
c
c       Find the pairs of integers covering the integers in
c       w(4+m : 3+m+(l+1)/2).
c
        call idd_pairsamps(n,l,w(4+m),l2,w(4+m+2*l),w(4+m+3*l))
        w(3) = l2
        call idd_copyints(l2,w(4+m+2*l),w(4+m+l))
c
c
c       Store the address within w of the idd_random_transf_init
c       initialization data.
c
        ia = 5+m+l+l2+4*l2+30+8*n
        w(4+m+l+l2) = ia
c
c
c       Store the initialization data for idd_sfft in w.
c
        call idd_sffti(l2,w(4+m+l),n,w(5+m+l+l2))
c
c
c       Store the initialization data for idd_random_transf_init in w.
c
        nsteps = 3
        call idd_random_transf_init(nsteps,m,w(ia),keep)
c
c
c       Calculate the total number of elements used in w.
c
        lw = 4+m+l+l2+4*l2+30+8*n + 3*nsteps*m+2*m+m/4+50
c
        if(25*m+90 .lt. lw) then
          !call prinf('lw = *',lw,1)
          !call prinf('25m+90 = *',25*m+90,1)
          stop
        endif
c
c
        return
        end
c
c
c
c
        subroutine idd_copyints(n,ia,ib)
c
c       copies ia into ib.
c
c       input:
c       n -- length of ia and ib
c       ia -- array to be copied
c
c       output:
c       ib -- copy of ia
c
        implicit none
        integer n,ia(n),ib(n),k
c
c
        do k = 1,n
          ib(k) = ia(k)
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idd_poweroftwo(m,l,n)
c
c       computes l = floor(log_2(m)) and n = 2**l.
c
c       input:
c       m -- integer whose log_2 is to be taken
c
c       output:
c       l -- floor(log_2(m))
c       n -- 2**l
c
        implicit none
        integer l,m,n
c
c
        l = 0
        n = 1
c
 1000   continue
          l = l+1
          n = n*2
        if(n .le. m) goto 1000
c
        l = l-1
        n = n/2
c
c
        return
        end


program test_hwm
!! https://map.nrl.navy.mil/map/pub/nrl/HWM/HWM14/HWM14_ess224-sup-0002-supinfo/README.txt
use hwm_interface, only : hwm_14, dwm_07

implicit none (type, external)

integer :: day = 150
real ::  &
 utsec = 12 * 3600, &
 alt_km = 400., &
 glat = -45.0, &
 glon = -85.0, &
 Ap = 80.0

real :: Wmeridional, Wzonal, Dw(2)

call hwm_14(day, utsec, alt_km, glat, glat, Ap, Wmeridional, Wzonal)

if (abs(Wmeridional - (-34.1767464)) > 0.001) error stop 'Wmeridional'
if (abs(Wzonal - (-64.3156433)) > 0.001) error stop 'Wzonal'

call dwm_07(day, utsec, alt_km, glat, glat, Ap, Dw)
if (abs(DW(1)-(24.6438866)) > 0.001) error stop 'Dw(1)'
if (abs(DW(2)-(-10.9287968)) > 0.001) error stop 'Dw(2)'

print *, "OK: HWM14"

end program


Module sp_hnfs
  implicit none
  integer, parameter:: dp=selected_real_kind(15,307)
  integer, parameter:: sp=selected_real_kind(6,37)
  integer, parameter:: si=selected_int_kind(1) ! very short integer -10..10 range
  integer, parameter:: li=selected_int_kind(18) ! Big integer -10^18..10^18 range
CONTAINS
  SUBROUTINE fco_16(n,spHNFs)
    integer, intent(in) :: n
    integer, allocatable, intent(out) :: spHNFs(:,:,:)

    integer, pointer :: diagonals(:,:) => null()
    real(dp) :: a,b,c,d,e,f
    integer :: nds, i, nhnfs, status, j, k, z
    integer(li) :: total_hnfs
    integer, allocatable :: temp_HNFs(:,:,:)

    real(dp) :: gamma11, gamma12, gamma21
    real(dp), allocatable :: bs(:)

    call get_HNF_diagonals(n,diagonals)

    nds = size(diagonals,2)
    nhnfs = 0
    total_hnfs = 0

    do i = 1,nds
       total_hnfs = total_hnfs + diagonals(2,i)*diagonals(3,i)**2
    end do

    allocate(temp_HNFs(3,3,total_hnfs),STAT=status)
    if (status/=0) stop "Failed to allocate memory in fco_16."

    do i =1,nds
       a = diagonals(1,i)
       c = diagonals(2,i)
       f = diagonals(3,i)

       if (MOD(c,2.0_dp)==0) then
          allocate(bs(2))
          bs = (/real(int(c)/2,dp),0.0_dp/)
       else
          allocate(bs(1))
          bs = (/0.0_dp/)
       end if
       do j=1, size(bs)
         do k=0, int(f-1)
           b = bs(j)
           e = real(k,dp)
           gamma11 = -b-2*b*e/c
           gamma21 = c+2*e
           if(MOD(gamma11,f)==0 .and. MOD(gamma21,f)==0)then
             do z=0,int(f-1)
               d = real(z,dp)
               gamma12 = a+2*d-(2*b*e/c)
               if(MOD(gamma12,f)==0)then
                 nhnfs = nhnfs + 1
                 temp_HNFs(:,:,nhnfs) = reshape((/ int(a), int(b), int(d), &
                    0, int(c), int(e), &
                    0, 0, int(f)/),(/3,3/))
               end if
             end do
           end if
       end do
    end do
    deallocate(bs)
  end do

    allocate(spHNFs(3,3,nhnfs))

    spHNFs(:,:,1:nhnfs) = temp_HNFs(:,:,1:nhnfs)

  end SUBROUTINE fco_16

  SUBROUTINE bct_6_7_15_18(n,spHNFs)
    integer, intent(in) :: n
    integer, allocatable, intent(out) :: spHNFs(:,:,:)

    integer, pointer :: diagonals(:,:) => null()
    real(dp) :: a,b,c,d,e,f
    integer :: nds, i, nhnfs, status, j, k, z
    integer(li) :: total_hnfs
    integer, allocatable :: temp_HNFs(:,:,:)

    real(dp) :: gamma21,gamma13,beta12,gamma12
    real(dp), allocatable :: es(:)

    call get_HNF_diagonals(n,diagonals)

    nds = size(diagonals,2)
    nhnfs = 0
    total_hnfs = 0

    do i = 1,nds
       total_hnfs = total_hnfs + diagonals(2,i)*diagonals(3,i)**2
    end do

    allocate(temp_HNFs(3,3,total_hnfs),STAT=status)
    if (status/=0) stop "Failed to allocate memory in bct_6_7_15_18."

    do i =1,nds
      a = diagonals(1,i)
      c = diagonals(2,i)
      f = diagonals(3,i)

      if (MOD(f,c)==0)then
        if (MOD(f,2.0_dp)==0)then
           allocate(es(2))
           es = (/0.0_dp,real(int(f)/2,dp)/)
        else
           allocate(es(1))
           es = (/0.0_dp/)
        end if
        do j=1,size(es)
          e = es(j)
          if(MOD(e,c)==0)then
            gamma21 = -c+e*e/c
            if(MOD(gamma21,f)==0)then
              do k=0,int(f-1)
                d = real(k)
                gamma13 = a+2*d
                if(MOD(gamma13,f)==0)then
                  do z=0,int(c-1)
                    b = real(z)
                    beta12 = b-d
                    if(MOD(beta12,c)==0)then
                      gamma12 = -b+d-(beta12*e/c)
                      if(MOD(gamma12,f)==0)then
                        nhnfs = nhnfs + 1
                        temp_HNFs(:,:,nhnfs) = reshape((/ int(a), int(b), int(d), &
                           0, int(c), int(e), &
                           0, 0, int(f)/),(/3,3/))
                      end if
                    end if
                  end do
                end if
              end do
            end if
          end if
        end do
      deallocate(es)
      endif
    end do

    allocate(spHNFs(3,3,nhnfs))

    spHNFs(:,:,1:nhnfs) = temp_HNFs(:,:,1:nhnfs)

  end SUBROUTINE bct_6_7_15_18

  SUBROUTINE rhom_4_2(n,spHNFs)
    integer, intent(in) :: n
    integer, allocatable, intent(out) :: spHNFs(:,:,:)

    integer, pointer :: diagonals(:,:) => null()
    real(dp) :: a,b,c,d,e,f
    integer :: nds, i, nhnfs, status, j, k, z
    integer(li) :: total_hnfs
    integer, allocatable :: temp_HNFs(:,:,:)

    real(dp) :: beta32,beta22,gamma11,gamma21,beta12,gamma12,gamma22
    real(dp), allocatable :: bs(:)

    call get_HNF_diagonals(n,diagonals)

    nds = size(diagonals,2)
    nhnfs = 0
    total_hnfs = 0

    do i = 1,nds
       total_hnfs = total_hnfs + diagonals(2,i)*diagonals(3,i)**2
    end do

    allocate(temp_HNFs(3,3,total_hnfs),STAT=status)
    if (status/=0) stop "Failed to allocate memory in rhom_4_2."

    do i =1,nds
       a = diagonals(1,i)
       c = diagonals(2,i)
       f = diagonals(3,i)

       if (MOD(c,2.0_dp)==0) then
          allocate(bs(2))
          bs = (/0.0_dp,real(int(c)/2,dp)/)
       else
          allocate(bs(1))
          bs = (/0.0_dp/)
       end if
       do j=1, size(bs)

           beta32 = -f+b*f/a
           if(MOD(beta32,c)==0) then
             do k=0, int(f-1)
               e = real(k)
               beta22 = -e+b*e/a
               gamma11 = b-2.0_dp*b*e/c
               gamma21 = c-2.0_dp*e
               if((MOD(e,a)==0) .and. (MOD(beta22,c)==0) .and. (MOD(gamma11,f)==0) &
                 .and. (MOD(gamma21,f)==0))then
                  do z=0,int(f-1)
                    d = real(z)
                    beta12 = -a+b-d+b*d/a
                    gamma12 = (-a+d*d/a)-(e*beta12/c)
                    gamma22 = (-e+d*e/a)-(e*beta22/c)
                    if((MOD(d,a)==0) .and. (MOD(beta12,c)==0) .and. (MOD(gamma12,f)==0) &
                      .and. (MOD(gamma22,f)==0))then
                      nhnfs = nhnfs + 1
                      temp_HNFs(:,:,nhnfs) = reshape((/ int(a), int(b), int(d), &
                         0, int(c), int(e), &
                         0, 0, int(f)/),(/3,3/))
                    end if
                  end do
                end if
              end do
            end if
          end do
       deallocate(bs)
     end do

    allocate(spHNFs(3,3,nhnfs))

    spHNFs(:,:,1:nhnfs) = temp_HNFs(:,:,1:nhnfs)

  END SUBROUTINE rhom_4_2

  SUBROUTINE get_HNF_diagonals(detS, diagonals)
    integer, intent(in) :: detS
    integer, pointer :: diagonals(:,:)

    integer i, j, id, quotient, status
    integer :: tempDiag(3,detS*3)

    id = 0 ! Number of diagonals found
    do i = 1,detS ! Loop over possible first factors
       if (.not. mod(detS,i)==0) cycle
       quotient = detS/i
       do j = 1,quotient  ! Loop over possible second/third factors
          if (.not. mod(quotient,j)==0) cycle
          id = id + 1
          tempDiag(:,id) = (/i, j, quotient/j /) ! Construct the factor triplet
       enddo
    enddo
    allocate(diagonals(3,id),STAT=status)
    if(status/=0) stop "Allocation failed in get_HNF_diagonals"
    diagonals = tempDiag(:,1:id)
  END SUBROUTINE get_HNF_diagonals
END Module sp_hnfs

program test
use sp_hnfs
  integer :: n = 10, arrSize,i = 1
  integer, allocatable :: spHNFs(:,:,:)

  call fco_16(n,spHNFs)
  arrSize = size(spHNFs,3)
  open (unit = 1, file = 'fort_spHNFs.txt', form='formatted')
  write(*,*), arrSize
  do i = 1,arrSize
    write(1,*), spHNFs(1:3,1,i)
    write(1,*), spHNFs(1:3,2,i)
    write(1,*), spHNFs(1:3,3,i)
  enddo
  close(1)

END program test


      SUBROUTINE FTUBE
C
C     THIS IS THE FLUID TUBE ELEMENT IN HEAT TRANSFER.
C     IT COMPUTES AND OUTPUTS THE CONDUCTIVITY AND/OR CAPACITY MATRICES
C     OF THE ELEMENT.
C
C     - SINGLE AND DOUBLE PRECISION VERSION -
C
C     EST ENTRY FOR -FTUBE- ELEMENT.
C     ==============================
C
C     EST( 1) = ELEMENT ID
C     EST( 2) = SIL-A
C     EST( 3) = SIL-B
C     EST( 4) = HEAT CAPACITY/UNIT VOLUME = RHO C
C     EST( 5) = VOLUME FLOW RATE = VDOT         P
C     EST( 6) = DIAMETER AT A
C     EST( 7) = DIAMETER AT B = DIAMETER AT A IF NOT DEFINED.
C     EST( 8) = CSID-A  NOT USED
C     EST( 9) = XA
C     EST(10) = YA
C     EST(11) = ZA
C     EST(12) = CSID-B  NOT USED
C     EST(13) = XB
C     EST(14) = YB
C     EST(15) = ZB
C     EST(16) = AVG TEMP OF ELEMENT.  NOT USED.
C
C
      LOGICAL          HEAT     ,ERROR
      INTEGER          DICT(7)  ,ESTID    ,IEST(1)
      REAL             RK(4)    ,ID1      ,ID2      ,DICT5
      DOUBLE PRECISION K(4)     ,LENGTH
      CHARACTER        UFM*23   ,UWM*25   ,UIM*29
      COMMON /XMSSG /  UFM      ,UWM      ,UIM
      COMMON /SYSTEM/  SYSBUF   ,IOUTPT
      COMMON /EMGPRM/  DUM15(15),KMB(3)   ,IPREC    ,ERROR    ,HEAT
      COMMON /EMGDIC/  DMMM(4)  ,ESTID
      COMMON /EMGEST/  EST(16)
      COMMON /CONDAS/  PI
      EQUIVALENCE      (IEST(1) , EST(1)) ,(RK(1)   , K(1))   ,
     1                 (DICT(5) , DICT5 )
C
      IF (.NOT.HEAT) GO TO 240
      DICT(1) = ESTID
      DICT(2) = 1
      DICT(3) = 2
      DICT(4) = 1
      DICT5   = 0.0
      IF (KMB(1) .EQ. 0) GO TO 170
C
C     CONDUCTIVITY
C
      RHOCP = EST(4)
      VDOT  = EST(5)
C
C     STORE CONDUCTIVITY BY COLUMNS
C
      K(1) = DBLE(RHOCP*VDOT)
C
      K(2) = -K(1)
      K(3) = 0.0D0
      K(4) = 0.0D0
C
C     OUTPUT VIA EMGOUT THE FULL MATRIX IN GLOBAL, UNSYMETRIC
C
      IFIL = 1
      ISZE = 4
      ASSIGN 170 TO IRTN
      IF (IPREC .EQ. 2) GO TO 160
  150 RK(1) = SNGL(K(1))
      RK(2) = SNGL(K(2))
      RK(3) = SNGL(K(3))
      RK(4) = SNGL(K(4))
  160 CALL EMGOUT (RK(1),K(1),ISZE,1,DICT,IFIL,IPREC)
      GO TO IRTN, (170,240)
C
C     CAPACITY MATRIX
C
  170 IF (KMB(3) .EQ. 0) GO TO 240
      RHOCP = EST( 4)
      VDOT  = EST( 5)
      ID1   = EST( 6)
      IF (EST(7)) 190,180,190
  180 ID2 = ID1
      GO TO 200
  190 ID2   = EST( 7)
  200 XA    = EST( 9)
      YA    = EST(10)
      ZA    = EST(11)
      XB    = EST(13)
      YB    = EST(14)
      ZB    = EST(15)
      LENGTH = DBLE((XB-XA))**2 + DBLE((YB-YA))**2 + DBLE((ZB-ZA))**2
      IF (LENGTH .GT. 0.0D0) GO TO 220
      LENGTH = DSQRT(LENGTH)
      WRITE  (IOUTPT,210) UIM,IEST(1)
  210 FORMAT (A29,' FROM ELEMENT FTUBE -', /5X,'ELEMENT WITH ID =',I9,
     1       ' HAS A ZERO LENGTH.')
      ERROR = .TRUE.
C
C     FILL AND OUTPUT CAPACITY MATRIX BY COLUMNS IN GLOBAL, SYMMETRIC.
C
  220 K(1) = (DBLE(RHOCP*PI*(ID1+ID2)))**2*LENGTH/32.0D0
      K(2) = 0.0D0
      K(3) = 0.0D0
      K(4) = K(1)
      DICT(2) = 2
      IFIL = 3
      ISZE = 2
      ASSIGN 240 TO IRTN
      IF (IPREC-1) 240,150,160
C
  240 RETURN
      END


c-----------------------------------------------------------------------
c This code was modified from a subroutine from the gamerf package at
c http://momonga.t.u-tokyo.ac.jp/~ooura/gamerf.html .
c The original copyright statement states:
c   Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp).
c   You may use, copy, modify this code for any purpose and
c   without fee. You may distribute this ORIGINAL package.
c
c Permission to distribute this modified gamma function code
c with the FFTLog package has been granted
c (email from Takuya Ooura to Andrew Hamilton dated 16 March 1999).
c
c Original gamerf2a.doc documentation states:
c
c   Gamma(z)=sqrt(2*pi)*(z+r)^(z-1/2)*exp(-z-r)
c            *(a_0
c            +a_1*(z-1)/z
c            +a_2*(z-1)*(z-2)/z/(z+1)
c            +a_3*(z-1)*(z-2)*(z-3)/z/(z+1)/(z+2)
c            +...)
c        a_n= f_n*(2*n)*(2*n-1)*(2*n-2)*...*(n+1)/1/2/3/.../n
c            -a_0*(2*n)*(2*n-1)*(2*n-2)*...*(n+1)/1/2/3/.../n
c            -a_1*(2*n)*(2*n-1)*(2*n-2)*...*(n+2)/1/2/3/.../(n-1)
c            -...
c            -a_(n-1)*(2*n)/1
c        f_n=1/sqrt(2*pi)*(1*2*3*...*n)*(n+1+r)^(-n-1/2)*exp(n+1+r)

c   C.Lanczos,A Precision Approximation of the Gamma Function,
c   J.SIAM Numer.Anal.Ser.B,Vol.1,1964
c
c Modified 28 Oct 98 by Andrew J S Hamilton
c http://casa.colorado.edu/~ajsh/
c (1) to return ln[Gamma(x)] with the correct phase,
c     as well as Gamma(x), and
c (2) to remain accurate for large absolute values of input x,
c     and for x near 0 or negative integers.
c-----------------------------------------------------------------------
      complex*16 function cdgamma(x,l)
      integer l
      complex*16 x
c *
c * Complex Gamma function in double precision.
c *
c * l = 0: Gamma(x)
c *     1: ln[Gamma(x)]
c *
      real*8 pi,pv,pu,pr,p1,p2,p3,p4,p5,p6,q1,q2,q3,q4,q5,q6
      parameter (
     &    pi = 3.14159265358979324d+00,
     &    pv = 7.31790632447016203d+00,
     &    pu = 3.48064577727581257d+00,
     &    pr = 3.27673720261526849d-02,
     &    p1 = 1.05400280458730808d+01,
     &    p2 = 4.73821439163096063d+01,
     &    p3 = 9.11395751189899762d+01,
     &    p4 = 6.62756400966213521d+01,
     &    p5 = 1.32280130755055088d+01,
     &    p6 = 2.93729529320536228d-01)
      parameter (
     &    q1 = 9.99999999999975753d-01,
     &    q2 = 2.00000000000603851d+00,
     &    q3 = 2.99999999944915534d+00,
     &    q4 = 4.00000003016801681d+00,
     &    q5 = 4.99999857982434025d+00,
     &    q6 = 6.00009857740312429d+00)
      real*8 big
      parameter (big=1.d20)
      real*8 t,ui,ur,vi,vr,wr,wi,xi,xr,yi,yr,zero
      data zero /0.d0/
c
      xr = dble(x)
      xi = dimag(x)
c---x = 0, -1, -2
      if (xr .eq. aint(xr) .and. xr .le. 0.d0 .and. xi .eq. 0.d0) then
c...Gamma
        if (l .eq. 0) then
          wr = xr / 2.d0
c   +Infinity at even negative integers
          if (wr .eq. aint(wr)) then
            yr = 1.d0 / zero
c   -Infinity at odd negative integers
          else
            yr = -1.d0 / zero
          endif
          yi = 0.d0
c...lnGamma
        elseif (l .eq. 1) then
c   real part is +Infinity
          yr = 1.d0 / zero
          yi = pi * aint(xr)
        endif
        goto 200
      endif
c---Re(x) < 1/2 : use reflection formula
      if (xr .lt. .5d0) then
          wr = 1.d0 - xr
          wi = -xi
      else
          wr = xr
          wi = xi
      end if
c---large |x|: keep only leading term of rational function
      t = wr * wr + wi * wi
      if (t .gt. big * big) then
c   Rational function v
        vr = wr / t + pr
        vi = - wi / t
c   ln(overall factor)
c   u = ln(x + pv) - 1
        yr = wr + pv
        ur = yr
        if (ur .lt. 0.d0) ur = - ur
        ui = wi
        if (ui .lt. 0.d0) ui = - ui
        if (ur.ge.ui) then
          t = wi / yr
          ur = log(ur) + log(1.d0 + t * t) / 2.d0 - 1.d0
        else
          t = yr / wi
          ur = log(ui) + log(1.d0 + t * t) / 2.d0 - 1.d0
        endif
        ui = atan2(wi, yr)
c---not large |x|
      else
c   u = u(x) = x + q6 = O(x)
        ur = wr + q6
c   v = v(x,u) = (x + q5) u = (x + q5)(x + q6) = O(x^2)
        vr = ur * (wr + q5) - wi * wi
        vi = wi * (wr + q5) + ur * wi
c   y = y(x,u,v) = p6 + p5 u + p4 v = p4 x^2 + ... = O(x^2)
        yr = p6 + (p5 * ur + p4 * vr)
        yi = p5 * wi + p4 * vi
c   u = u(x,v) = (x + q4) v = (x + q4)(x + q5)(x + q6) = O(x^3)
        ur = vr * (wr + q4) - vi * wi
        ui = vi * (wr + q4) + vr * wi
c   v = v(x,u) = (x + q3) u = (x + q3)(x + q4)...(x + q6) = O(x^4)
        vr = ur * (wr + q3) - ui * wi
        vi = ui * (wr + q3) + ur * wi
c   y = y(y,u,v) = y + p3 u + p2 v = p2 x^4 + ... = O(x^4)
        yr = yr + (p3 * ur + p2 * vr)
        yi = yi + (p3 * ui + p2 * vi)
c   u = u(x,v) = (x + q2) v = (x + q2)(x + q3)...(x + q6) = O(x^5)
        ur = vr * (wr + q2) - vi * wi
        ui = vi * (wr + q2) + vr * wi
c   v = v(x,u) = (x + q1) u = (x + q1)(x + q2)...(x + q6) = O(x^6)
        vr = ur * (wr + q1) - ui * wi
        vi = ui * (wr + q1) + ur * wi
c   Numerator
c   y = y(y,u,v) = y + p1 u + v = x^6 + ... = O(x^6)
c     = (x+q1)...(x+q6) + p1 (x+q2)...(x+q6) + ... + p5 (x+q6) + p6
        yr = yr + (p1 * ur + vr)
        yi = yi + (p1 * ui + vi)
c   Denominator
c   u = x v = x(x + q1)(x + q2)...(x + q6) = O(x^7)
        ur = vr * wr - vi * wi
        ui = vi * wr + vr * wi
c   t = |u|^2
        t = ur * ur + ui * ui
c   Rational function v = y u*/|u|^2 + pr = y/u + pr = pr + 1/x + ...
c     = pr + 1/x ( 1 + 1/(x+q1) ( p1 + 1/(x+q2) ( p2 + ...
        vr = (yr * ur + yi * ui) / t + pr
        vi = (yi * ur - yr * ui) / t
c   Overall factor
c   u = ln(x + pv) - 1
        yr = wr + pv
        ur = log(yr * yr + wi * wi) / 2.d0 - 1.d0
        ui = atan2(wi, yr)
      endif
c---lnGamma
c   y = u(x - .5) - pu
c     = (x - .5) [ln(x + pv) - 1] - pu
      yr = ur * (wr - 0.5d0) - ui * wi - pu
      yi = ui * (wr - 0.5d0) + ur * wi
c   y = y + ln(v)
c     = (x - .5) [ln(x + pv) - 1] - pu + ln(Rational)
c     = lnGamma(x)
      yr = yr + log(vr * vr + vi * vi) / 2.d0
      yi = yi + atan2(vi, vr)
c---Reflection formula Gamma(x) Gamma(1-x) = pi/sin(pi x)
c   sign of Gamma
      t = 1.d0
      if (xr .lt. .5d0) then
        wi = anint(xr)
        wr = xr - wi
        if (wi .gt. xr) wi = wi - 1.d0
c   case of real x
        if (xi .eq. 0.d0) then
c   w = ln[sin(pi x)]
          wr = log(sin(pi * abs(wr)))
          if (l .eq. 0) then
            if (wi .ne. 2.d0 * aint(wi / 2)) t = -1.d0
            wi = 0.d0
          elseif (l .eq. 1) then
            wi = - pi * wi
          endif
c   case where imaginary part of x is < 1 in absolute value
        elseif (abs(xi) .lt. 1.d0) then
          if (l .eq. 0) then
            if (wi .ne. 2.d0 * aint(wi / 2.d0)) t = -1.d0
            ui = 0.d0
          elseif (l .eq. 1) then
            ui = -pi * wi
            if (xi .lt. 0.d0) ui = -ui
          endif
          wr = pi * wr
          wi = pi * xi
          vr = sin(wr) * cosh(wi)
          vi = cos(wr) * sinh(wi)
          if (wr .lt. 0.d0) then
            vr = -vr
            vi = -vi
          endif
c   w = ln[sin(pi x)]
          wr = log(vr * vr + vi * vi) / 2.d0
          wi = ui + atan2(vi, vr)
c   case where imaginary part of x is >= 1 in absolute value
        else
          if (l .eq. 0) then
            if (wi .ne. 2.d0 * aint(wi / 2)) t = -1.d0
            if (wr .ge. 0.d0) then
              ui = pi * (.5d0 - wr)
            else
              ui = pi * (- .5d0 - wr)
            endif
          elseif (l .eq. 1) then
            ui = pi * (.5d0 - xr)
          endif
          wi = exp(- 2.d0 * pi * abs(xi))
          wr = 2.d0 * pi * wr
          vr = (1.d0 - cos(wr) * wi) / 2.d0
          vi = - sin(wr) * wi / 2.d0
          ur = pi * xi
c   w = ln[sin(pi x)]
          if (xi .gt. 0.d0) then
            wr = ur + log(vr * vr + vi * vi) / 2.d0
            wi = ui + atan2(vi, vr)
          elseif (xi .lt. 0.d0) then
            wr = - ur + log(vr * vr + vi * vi) / 2.d0
            wi = - ui - atan2(vi, vr)
          endif
        endif
c   y = ln[Gamma(x)]
        yr = log(pi) - yr - wr
        yi = - yi - wi
      endif
c---Gamma
      if (l .eq. 0) then
        ur = exp(yr)
        if (xi .eq. 0.d0) then
          yr = t * ur
          yi = 0.d0
        else
          yr = t * ur * cos(yi)
          yi = ur * sin(yi)
        endif
      endif
c---finish
  200 cdgamma = dcmplx(yr, yi)
      end
c


      FUNCTION ALG2 (S,P)
C
      COMMON /GAS/ G,EJ,R,CP,GAMMA,ROJCP
C
      ALG2=CP*EXP(S/CP+ROJCP*ALOG(P))
      RETURN
      END


ccc_____________________________________________________________________
ccc
      subroutine phs_shft(dt,x,nfreq,nch,dr,nwin)

ccc   subroutine corrects for fractional offsets in sampling times
ccc   NOTE : this is not the same as the version of phs_shft used for
ccc   the SEED file verison of dnff

      complex tc,t
      real x(nch,2,nfreq),dr,t1,pi2,dt
      integer nwin
      parameter(pi2 = 6.28318)

      do j = 1,nch
ccc      now do the phase shift
         t1 =   -pi2*dt/(dr*nwin)
         do i = 1,nfreq
            tc = cmplx(cos(i*t1),sin(i*t1))
            t = tc*cmplx(x(j,1,i),x(j,2,i))
            x(j,1,i) = real(t)
            x(j,2,i) = aimag(t)
         enddo
      enddo
      return
      end


MODULE force_ion_mol_module

  use atom_module
  use pseudopot_module

  implicit none

  PRIVATE
  PUBLIC :: calc_force_ion_mol

CONTAINS

  SUBROUTINE calc_force_ion_mol(force)
    implicit none
    real(8),intent(INOUT) :: force(:,:)
    integer :: a,b
    real(8) :: r3,c1,ax,ay,az,bx,by,bz

    force(1:3,1:Natom) = 0.0d0

    do a=1,Natom

       ax = aa_atom(1,a)
       ay = aa_atom(2,a)
       az = aa_atom(3,a)

       do b=1,Natom

          if ( a == b ) cycle

          bx = aa_atom(1,b)
          by = aa_atom(2,b)
          bz = aa_atom(3,b)

          r3 = sqrt( (ax-bx)**2 + (ay-by)**2 + (az-bz)**2 )**3
          c1 = Zps(ki_atom(a))*Zps(ki_atom(b))/r3

          force(1,a) = force(1,a) + c1*(ax-bx)
          force(2,a) = force(2,a) + c1*(ay-by)
          force(3,a) = force(3,a) + c1*(az-bz)

       end do ! b

    end do ! a

    return
  END SUBROUTINE calc_force_ion_mol

END MODULE force_ion_mol_module


	PROGRAM ZTEST
	DO 10 I = 0,22
	ZTR = .4*(I-10)
	ZTI = .0
C	DO 10 J = 0,6
C	ZTI = J-3
	CALL Z(ZTR,ZTI,ZR,ZI,DZR,DZI)
	WRITE(7,100) ZTR,ZTI,ZR,ZI,DZR,DZI
  10	CONTINUE
	DO 20 I = 1,20
	ZTR = I
	CALL Z(ZTR,ZTI,ZR,ZI,DZR,DZI)
	WRITE(7,100) ZTR,ZTI,ZR,ZI,DZR,DZI
  20	CONTINUE
 100	FORMAT(6E15.7)
	STOP
	END
      SUBROUTINE Z(ZTR,ZTI,ZR,ZI,DZR,DZI)
C
C	THIS ROUTINE RETURNS Z(ZETA) AS DEFINED IN EQ.(1) OF
C	FRIED AND CONTE 'THE PLASMA DISPERSION FUNCTION'
C	AND ITS DERIVATIVE.
C
	DOUBLE PRECISION Z2R,Z2I,XN,SR,SI,T,TR,TI,TTR,TTI,U,UR,UI
C      DATA DIV,EXLIM /2.6,80./
      DATA DIV,EXLIM /3.3,80./
C
      TE = ZTR*ZTR - ZTI*ZTI
      IF (ABS(TE)-EXLIM) 100,100,105
C	ENTRY FOR REASONABLE EXPONENT
  100 CONTINUE
      U=EXP(-TE)
      UR=U*SIN(2.*ZTR*ZTI)*1.772453851
      UI=U*COS(2.*ZTR*ZTI)*1.772453851
      GO TO 115
C	ENTRY FOR LARGE (MAGNITUDE) EXPONENT
  105 IF ((AR*AR-WI*WI).LT.0..AND.WI.LT.0.) GO TO 110
C	EXPONENT IS LARGE AND NEGATIVE
      UR=0.
      UI=0.
      GO TO 115
C	EXPONENT IS LARGE AND POSITIVE
  110 U=EXP(EXLIM)
      WRITE (7,180) AR,WI,W,TP,B
      UR=U*SIN(2.*ZTR*ZTI)*1.772453851
      UI=U*COS(2.*ZTR*ZTI)*1.772453851
  115 IF (ZTR*ZTR+ZTI*ZTI-(DIV)**2) 120,120,135
C	POWER SERIES FOR SMALL ARGUMENT
  120 Z2R=ZTR*ZTR-ZTI*ZTI
      Z2I=2.*ZTR*ZTI
      TR=-2.*ZTR
      TI=-2.*ZTI
      SR=TR+UR
      SI=TI+UI
      DO 125 N=1,40
        XN=N+.5D00
        T=-(TR*Z2R-TI*Z2I)/XN
        TI=-(TR*Z2I+TI*Z2R)/XN
        TR=T
        SR=SR+TR
        SI=SI+TI
        IF (ABS(ZR)+ABS(ZI)-1.0E+6*(ABS(TR)+ABS(TI))) 125,125,130
  125   CONTINUE
  130 ZR = SR
      ZI = SI
      DZR = -2.*(1.+SR*ZTR-SI*ZTI)
      DZI = -2.*(SR*ZTI+SI*ZTR)
      RETURN
C	ASYMPTOTIC SERIES FOR LARGE ARGUMENT
  135 SIG = 1.
      IF(ZTI.LT.0.) SIG  = 2.
      IF(ZTI.GT.0.) SIG  = 0.
      SR=QR(1.,0.,ZTR,ZTI)
      SI=QI(1.,0.,ZTR,ZTI)
      YR=SR*SR-SI*SI
      YI=2.*SR*SI
      TR=YR
      TI=YI
      DZR = -2.*SIG*(ZTR*UR - ZTI*UI) + YR
      DZI = -2.*SIG*(ZTR*UI + ZTI*UR) + YI
      DO 170 N=2,30
        XN=N-.5D00
        TTR=XN*(TR*YR-TI*YI)
        TTI=XN*(TR*YI+TI*YR)
C	EXIT IF TERMS START TO INCREASE
        IF (ABS(TR)+ABS(TI)-ABS(TTR)-ABS(TTI)) 175,165,165
  165   TR=TTR
        TI=TTI
        DZR=DZR+TR
        DZI=DZI+TI
C	EXIT IF TERMS ARE SUFFICIENTLY SMALL
        IF (ABS(DZR)+ABS(DZI)-1.0E+6*(ABS(TR)+ABS(TI))) 170,175,175
  170   CONTINUE
  175 ZR = -.5*((DZR+2.)*SR - DZI*SI)
      ZI = -.5*((DZR+2.)*SI + DZI*SR)
	RETURN
C
  180 FORMAT (' EXPONENT TOO LARGE IN Z ',6E15.7)
      END
      FUNCTION QR (A,B,C,D)
      QR = (A*C+B*D)/(C*C+D*D)
      RETURN
      END
      FUNCTION QI (A,B,C,D)
      QI=(B*C-A*D)/(C*C+D*D)
      RETURN
      END
      FUNCTION TPR (A,B,C,D,E,F)
      TPR=E*(A*C-B*D)-F*(B*C+A*D)
      RETURN
      END
      FUNCTION TPI (A,B,C,D,E,F)
      TPI=F*(A*C-B*D)+E*(B*C+A*D)
      RETURN
      END


P:=100; WHILE (P:=NextPrime(P)) <= 150 DO stuff;