      SUBROUTINE BLOCARF( ZS,N,LAG,NS0,KMAX,ZMEAN,SUM,AIC,C,B,A,SD,NP,
     *                    NE,SXX )
C

C
cc      PROGRAM  BLOCAR
C.......................................................................
C.....PLANNED BY H.AKAIKE...............................................
C.....DESIGNED BY H.AKAIKE AND G.KITAGAWA...............................
C.....PROGRAMMED BY G.KITAGAWA AND F.TADA...............................
C.....ADDRESS: THE INSTITUTE OF STATISTICAL MATHEMATICS, 4-6-7 MINAMI-AZ
C..............MINATO-KU, TOKYO 106, JAPAN..............................
C.....DATE OF THE LATEST REVISION:  MAR. 6,1979.........................
C.......................................................................
C.....THIS PROGRAM WAS ORIGINALLY PUBLISHED IN "TIMSAC-78", BY H.AKAIKE,
C.....G.KITAGAWA, E.ARAHATA AND F.TADA, COMPUTER SCIENCE MONOGRAPHS, NO.
C.....THE INSTITUTE OF STATISTICAL MATHEMATICS, TOKYO, 1979.............
C.......................................................................
C     TIMSAC 78.3.2.
C     _                  ___                __
C     BAYESIAN METHOD OF LOCALLY STATIONARY AR MODEL FITTING; SCALAR CAS
C
C     THIS PROGRAM LOCALLY FITS AUTOREGRESSIVE MODELS TO NON-STATIONARY
C     SERIES BY A BAYESIAN PROCEDURE.  POWER SPECTRA FOR STATIONARY SPAN
C     ARE GRAPHICALLY PRINTED OUT.  (THIS PROGRAM IS TENTATIVE.)
C
C     INPUTS REQUIRED:
C             MT:       INPUT DEVICE FOR ORIGINAL DATA (MT=5 : CARD READ
C             LAG:      UPPER LIMIT OF THE ORDER OF AR MODEL, MUST BE LE
C                       OR EQUAL TO 50.
C             NS:       LENGTH OF BASIC LOCAL SPAN
C             KSW:      =0  CONSTANT VECTOR IS NOT INCLUDED AS A REGRESS
C                       =1  CONSTANT VECTOR IS INCLUDED AS THE FIRST REG
C
C               -- THE FOLLOWING INPUTS ARE REQUESTED BY SUBROUTINE REDA
C             TITLE:    SPECIFICATION OF DATA
C             N:        DATA LENGTH, MUST BE LESS THAN OR EQUAL TO 10000
C             DFORM:    INPUT DATA SPECIFICATION STATEMENT.
C                       -- EXAMPLE  --     (8F10.5)
C             (Z(I),I=1,N):  ORIGINAL DATA
C               --------------------------------------------------------
C
C
C     AT EACH STAGE OF MODELLING OF LOCAL AR MODEL, A TWO-STEP BAYESIAN
C     PROCEDURE IS APPLIED
C        1.   AVERAGING OF THE MODELS WITH DIFFERENT ORDERS FITTED TO TH
C             NEWLY OBTAINED DATA (BY SUBROUTINE ARBAYS).
C        2.   AVERAGING OF THE MODELS FITTED TO THE PRESENT AND PRECEDIN
C             (AS FAR AS KMAX(<21)) SPANS.
C     AS TO THE AVERAGING 1, SEE THE COMMENTS OF PROGRAM UNIBAR.
C
C     AIC OF THE MODEL FITTED TO THE NEW SPAN IS DEFINED BY
C
C          AIC = NS * LOG( SD ) + 2 * EK,
C     WHERE
C          NS:     LENGTH OF NEW DATA
C          SD:     INNOVATION VARIANCE
C          EK:     EQUIVALENT NUMBER OF PARAMETERS, DEFINED AS THE SUM O
C                  SQUARES OF THE BAYESIAN WEIGHTS
C
C     AIC OF THE MODELS FITTED TO THE PRECEDING SPANS ARE DEFINED BY
C
C          AIC(J+1) = NS * LOG( SD(J) ) + 2     (J=1,KC)
C     WHERE
C          SD(J):  PREDICTION ERROR VARIANCE BY THE MODEL FITTED TO J
C                  PERIODS FORMER SPAN.
C       ---------------------------------------------------------------
C       REFERENCES:
C          G.KITAGAWA AND H.AKAIKE(1978), "A PROCEDURE FOR THE MODELING
C          OF NON-STATIONARY TIME SERIES.",  ANN. INST. STATIST. MATH.,
C          30,B,351-363.
C
C          H.AKAIKE(1978), "A BAYESIAN EXTENSION OF THE MINIMUM AIC
C          PROCEDURE OF AUTOREGRESSIVE MODEL FITTING.",  RESEARCH MEMO.
C          NO. 126, THE INSTITUTE OF STATISTICAL MATHEMATICS; TOKYO.
C       ---------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS PROGRAM:
C             REDATA
C             NONSTB
C             PRINTA
C             NRASPE
C       ---------------------------------------------------------------
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: BLOCARF
C
CC      IMPLICIT REAL * 8 ( A-H , O-Y )
cxx      IMPLICIT REAL * 8 ( A-H , O-Z )
cc      REAL * 4  TITLE(20) , TTL(13)
cc      DIMENSION Z(10000)
cc      DIMENSION  X(200,51) , D(200) , A(50)
cxx      DIMENSION  Z(N), ZS(N)
cxx      DIMENSION  X(NS0,LAG+1), A(LAG,KMAX)
cxx      DIMENSION  AIC(KMAX,KMAX), C(KMAX,KMAX)
cxx      DIMENSION  B(LAG,KMAX), SD(KMAX)
cxx      DIMENSION  NP(KMAX), NE(KMAX)
      INTEGER :: N, LAG, NS0, KMAX, NP(KMAX), NE(KMAX)
      REAL(8) :: ZS(N), ZMEAN, SUM, AIC(KMAX,KMAX), C(KMAX,KMAX),
     1           B(LAG,KMAX), A(LAG,KMAX), SD(KMAX), SXX(121,KMAX)
cc      DATA  TTL / 4H  CU,4HRREN,4HT MO,4HDEL ,4H(AVE,4HRAGE,4H BY ,4HTHE
cc     1 ,4HBAYE,4HSIAN,4H WEI,4HGHTS,4H)    /
C
cxx      DIMENSION    SXX(121,KMAX)
cxx      DIMENSION    F(LAG,KMAX)
      REAL(8) :: Z(N), X(NS0,LAG+1), F(LAG,KMAX), BB
C
      EXTERNAL  SETX1
C
cc      CHARACTER(100) IFLNAM,OFLNAM
cc      CALL FLNAM2( IFLNAM,OFLNAM,NFL )
cc      IF (NFL.EQ.0) GO TO 999
cc      IF (NFL.EQ.2) THEN
cc         OPEN( 6,FILE=OFLNAM,ERR=900,IOSTAT=IVAR )
cc      ELSE
cc         CALL SETWND
cc      END IF
C
C
      KSW = 0
cc      KMAX = 20
cc      MJ1 = 200
      MJ1 = NS0
      ISW = 0
C
CC      READ( 5,1 )     MT
cc      MT = 5
cc      OPEN( MT,FILE=IFLNAM,ERR=910,IOSTAT=IVAR,STATUS='OLD' )
cc      READ( 5,1 )     LAG , NS
      NS = NS0
C
cc      WRITE( 6,3 )
cc      IF( KSW .EQ. 1 )     WRITE( 6,5 )
cc      IF( KSW .NE. 1 )     WRITE( 6,4 )
cc      WRITE( 6,6 )
cc      WRITE( 6,2 )   LAG , NS , MT
C
C          ---------------------
C          ORIGINAL DATA LOADING
C          ---------------------
C
cc      CALL  REDATA( Z,N,MT,TITLE )
cc      SUBROUTINE  REDATA( X,N,MT,TITLE )
      CALL  REDATA( ZS,Z,N,ZMEAN,SUM )
cc      CLOSE( MT )
C
C     ---  INITIAL SETTING  ---
      LAG1 = LAG+1
      N0 = 0
      K = LAG + KSW
      K3 = K*3
C
      NR = 0
      KC = 0
   10 CONTINUE
      NR = NR+1
C
C          -----------------------------------
C          LOCALLY STATIONARY AR-MODEL FITTING
C          -----------------------------------
C
cc      CALL  NONSTB( SETX1,Z,X,D,LAG,N0,NS,KMAX,KSW,ISW,TITLE,MJ1,A,SD )
cx      CALL  NONSTB( SETX1,Z,X,LAG,N0,NS,KMAX,KSW,ISW,MJ1,KC,F,
      CALL  NONSTB( SETX1,Z,N,X,LAG,N0,NS,KMAX,KSW,ISW,MJ1,KC,F,
     *              AIC(1,NR),C(1,NR),B(1,NR),A(1,NR),SD(NR) )
C
cc      NP = N0 + LAG + 1
cc      NE = NP+NS-1
cc      CALL  PRINTA( A,SD,K,TTL,13,TITLE,NP,NE )
      NP(NR) = N0 + LAG + 1
      NE(NR) = NP(NR)+NS-1
C
C     ---  SPECTRUM DISPLAY  ---
cc      CALL  NRASPE( SD,A,B,K,0,120,TITLE )
      CALL  NRASPE( SD(NR),A(1,NR),BB,K,0,120,SXX(1,NR) )
C
C
C     ---  PREPARATION FOR THE NEXT STEP  ---
      N0 = N0 + NS
      IF(N0+NS+LAG1.GT.N)      NS = N-N0-LAG1
      IF(N-N0-NS-LAG1.LT.K3)   NS = N-N0-LAG1
      IF( N0+LAG1 .LT. N )     GO TO 10
C
C
cc      GO TO 999
C
cc  900 CONTINUE
cc      WRITE(6,600) IVAR,OFLNAM
cc      GO TO 999
C
cc  910 CONTINUE
cc      IF (NFL.EQ.2) CLOSE( 6 )
cc#ifdef __linux__
ccC	reopen #6 as stdout
cc      IF (NFL.EQ.2) OPEN(6, FILE='/dev/fd/1')
cc#endif
ccC /* __linux__ */
cc      WRITE(6,610) IVAR,IFLNAM
cc      GO TO 999
C
cxx  600 FORMAT(/,' !!! Output_Data_File OPEN ERROR ',I8,//5X,100A)
cxx  610 FORMAT(/,' !!! Input_Data_File OPEN ERROR ',I8,//5X,100A)
C
      RETURN
cxx    1 FORMAT( 16I5 )
cxx    2 FORMAT( ///1H ,'  FITTING UP TO THE ORDER  K =',I3,'  IS TRIED',/,
cxx     1'   BASIC LOCAL SPAN  NS =',I4,/,'   ORIGINAL DATA INPUT DEVICE  M
cxx     2T =',I3 )
cxx    3 FORMAT( //' PROGRAM TIMSAC 78.3.2',/,'   BAYESIAN METHOD OF LOCALL
cxx     *Y STATIONARY AR MODEL FITTING;   SCALAR CASE',//,'   < BASIC AUTOR
cxx     *EGRESSIVE MODEL >' )
cxx    4 FORMAT( 1H ,10X,'Z(I) = A(1)*Z(I-1) + A(2)*Z(I-2) + ... + A(M)*Z(I
cxx     1-M) + E(I)' )
cxx    5 FORMAT( 1H ,10X,'Z(I) = A(1) + A(2)*Z(I-1) + ... + A(M+1)*Z(I-M) +
cxx     1 E(I)' )
cxx    6 FORMAT( 1H ,2X,'WHERE',/,11X,'M:     ORDER OF THE MODEL',/,11X,'E(
cxx     1I):  GAUSSIAN WHITE NOISE WITH MEAN 0  AND  VARIANCE SD(M).' )
      END
cc      SUBROUTINE  NONSTB( SETX,Z,X,D,LAG,N0,NS,KMAX,KSW,ISW,TITLE,MJ1,A,
cc     1SD )
cx      SUBROUTINE  NONSTB( SETX,Z,X,LAG,N0,NS,KMAX1,KSW,ISW,MJ1,KC,F,
      SUBROUTINE  NONSTB( SETX,Z,N,X,LAG,N0,NS,KMAX1,KSW,ISW,MJ1,KC,F,
     1AIC,C,B,A,SD )
C
C     BAYESIAN TYPE NON-STATIONARY AUTOREGRESSIVE MODEL FITTING PROCEDUR
C
C     THIS SUBROUTINE FIRST FITS AN AUTOREGRESSIVE MODEL TO THE NEWLY OB
C     DATA SPAN AND THEN PRODUCES A BAYESIAN MODEL BY AVERAGING THE MODE
C     FITTED TO THE PRESENT AND PRECEDING SPANS.
C
C     BAYESIAN WEIGHT OF THE MODEL FITTED TO I PERIODS FORMER SPAN IS
C     DEFINED BY
C          C(I)  =  CONST * P(I) / (I+1)
C     WHERE
C          CONST  =  NORMALIZING CONSTANT
C          P(I)  =  EXP( -0.5*AIC(I) )
C          AIC(I)  =  AIC WITH RESPECT TO THE PRESENT DATA.
C       ----------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS SUBROUTINE
C             DMIN
C             ARBAYS
C             ARCOEF
C             BAYSWT
C             REDUCT
C             SDCOMP
C       ----------------------------------------------------------------
C
C     INPUTS:
C        SETX:  EXTERNAL SUBROUTINE DESIGNATION
C        Z:     ORIGINAL DATA, OUTPUT OF SUBROUTINE REDATA
C        X:     WORKING AREA
C        D:     WORKING AREA
C        LAG:   UPPER LIMIT OF ORDER OF AR-MODEL
C        N0:    INDEX OF THE END POINT OF THE FORMER SPAN
C        NS:    LENGTH OF BASIC LOCAL SPAN
C        KMAX:  MAXIMUM NUMBER OF PRECEDING MODELS STORED
C        KSW:   =0  CONSTANT VECTOR IS NOT INCLUDED AS A REGRESSOR
C               =1  CONSTANT VECTOR IS INCLUDED AS THE FIRST REGRESSOR
C        ISW:   PRINT OUT CONTROL
C        TITLE: TITLE OF DATA
C        MJ1:   ABSOLUTE DIMENSION OF X
C
C     OUTPUTS:
C        A:     AR-COEFFICIENTS OF THE CURRENT MODEL
C        SD:    INNOVATION VARIANCE OF THE CURRENT MODEL
C
cxx      IMPLICIT  REAL*8  ( A-H,O-Z )
CC      REAL*4  Z , TITLE
cc      REAL*4  TITLE
cc      DIMENSION  X(MJ1,1) , D(1) , A(1) , Z(1) , TITLE(1)
cc      DIMENSION  F(50,20) , AIC(21) , C(50) , B(50)
cx      DIMENSION  X(MJ1,1) , D(LAG+KSW+1), A(1) , Z(1)
cxx      DIMENSION  X(MJ1,1) , D(LAG+KSW+1), A(LAG+KSW) , Z(N)
cxx      DIMENSION  F(LAG+KSW,KMAX1) , AIC(KMAX1) , C(KMAX1) , B(LAG+KSW)
cxx      DIMENSION  SDD(LAG+KSW+1), AICC(LAG+KSW+1), DIC(LAG+KSW+1)
cxx      DIMENSION  B1(LAG+KSW), W(LAG+KSW+1)
      INTEGER :: N, LAG, N0, NS, KMAX1, KSW, ISW, MJ1, KC
      REAL(8) :: Z(N), X(MJ1,1), F(LAG+KSW,KMAX1), AIC(KMAX1),
     1           C(KMAX1), B(LAG+KSW), A(LAG+KSW), SD
      REAL(8) :: D(LAG+KSW+1), SDD(LAG+KSW+1), AICC(LAG+KSW+1),
     1           DIC(LAG+KSW+1), B1(LAG+KSW), W(LAG+KSW+1),
     2           AICB, AICM, SDMIN, PN
cc      DATA  KC / 0 /
      EXTERNAL  SETX
C
      K = LAG + KSW
      KMAX = KMAX1-1
C
C     ---  HOUSEHOLDER REDUCTION  ---
cc      CALL  REDUCT( SETX,Z,D,NS,N0,K,MJ1,LAG,X )
      CALL  REDUCT( SETX,Z,NS,N0,K,MJ1,LAG,X )
C
C
C     ---  BAYESIAN MODEL FITTED TO THE NEW SPAN  ---
cc      CALL  ARBAYS( X,D,K,LAG,NS,ISW,TITLE,MJ1,A,B,SD,AICB )
cxx      CALL ARBAYS( X,D,K,LAG,NS,ISW,MJ1,SDD,AICC,DIC,AICM,SDMIN,IMIN,
      CALL ARBAYS( X,D,K,NS,ISW,MJ1,SDD,AICC,DIC,AICM,SDMIN,IMIN,
     *             A,B1,B,W,SD,PN,AICB )
C
      IF( KC .EQ. 0 )  GO TO 110
C
C
C     ---  PREDICTION ERROR VARIANCE AND AIC OF THE FORMER MODELS  ---
      AIC(1) = AICB
      DO 30  J=1,KC
         DO 20  I=1,K
cxx   20    D(I) = F(I,J)
         D(I) = F(I,J)
   20    CONTINUE
        CALL  ARCOEF( D,K,A )
cc        CALL  SDCOMP( X,A,D,NS,K,MJ1,SD )
        CALL  SDCOMP( X,A,NS,K,MJ1,SD )
cxx   30 AIC(J+1) = NS*DLOG( SD ) + 2.D0
      AIC(J+1) = NS*DLOG( SD ) + 2.D0
   30 CONTINUE
C
C
C     ---  BAYESIAN WEIGHTS OF THE MODEL  ---
c-------------------------------   06/11/01
ccx      AICM = DMIN( AIC,KC )
      AICM = AIC(1)
      DO 33  I=1,KC
cxx   33 IF( AIC(I) .LT. AICM )  AICM = AIC(I)
      IF( AIC(I) .LT. AICM )  AICM = AIC(I)
   33 CONTINUE
c-------------------------------
      CALL  BAYSWT( AIC,AICM,KC,2,C )
C
      KC1 = KC+1
cc      WRITE( 6,3 )     C(1) , AIC(1)
cc      DO 35  I=2,KC1
cc         IM1 = I-1
cc   35 WRITE( 6,4 )     IM1 , C(I) , AIC(I)
C
C
C     ---  AVERAGING OF THE MODELS  ---
      DO 40  I=1,K
cxx   40 B(I) = B(I)*C(1)
      B(I) = B(I)*C(1)
   40 CONTINUE
      DO 70  J=1,KC
         DO 50  I=1,K
cxx   50    A(I) = F(I,J)
         A(I) = F(I,J)
   50    CONTINUE
         DO 60  I=1,K
cxx   60    B(I) = B(I) + C(J+1)*A(I)
         B(I) = B(I) + C(J+1)*A(I)
   60    CONTINUE
   70 CONTINUE
cc      WRITE( 6,5 )     (B(I),I=1,K)
C
C
C     ---  AR-COEFFICIENTS OF THE CURRENT BAYESIAN MODEL  ---
      CALL  ARCOEF( B,K,A )
C
C
C     ---  "PARCOR'S" STORED  ---
cxx      DO 100  J=1,KC
      DO 101  J=1,KC
         II = KC1-J
         DO 100  I=1,K
cxx  100 F(I,II+1) = F(I,II)
         F(I,II+1) = F(I,II)
  100    CONTINUE
  101 CONTINUE
  110 CONTINUE
      DO 120  I=1,K
cxx  120 F(I,1) = B(I)
      F(I,1) = B(I)
  120 CONTINUE
      KC = MIN0( KC+1,KMAX )
C
C
C     ---  PREDICTION ERROR VARIANCE COMPUTED  ---
cc      CALL  SDCOMP( X,A,D,NS,K,MJ1,SD )
      CALL  SDCOMP( X,A,NS,K,MJ1,SD )
C
      RETURN
C
cxx    3 FORMAT( ///1H ,13X,'AR-MODEL FITTED TO  !  BAYESIAN WEIGHTS  ! AIC
cxx     1 WITH RESPECT TO THE PRESENT DATA',/,10X,83(1H-),/,1H ,11X,'CURREN
cxx     2T BLOCK',9X,'!',F13.5,7X,'!',F21.3 )
cxx    4 FORMAT( 1H ,6X,I5,' PERIOD FORMER BLOCK  !',F13.5,7X,'!',F21.3 )
cxx    5 FORMAT( //1H ,'PARTIAL AUTOCORRELATION  B(I) (I=1,K)',/,(1X,10D13.
cxx     15) )
C
      END


      subroutine assumed_size(arr, d1)
        implicit none
        integer, intent(in) :: d1
        complex*16, intent(inout) :: arr(d1, *)

        arr(1:d1, 1) = cmplx(10,20,kind=kind(arr))
      end subroutine assumed_size
      subroutine explicit_shape(arr, d1, d2)
        implicit none
        integer, intent(in) :: d1, d2
        real(kind=8), intent(inout) :: arr(d1,d2)

        arr = 10.0

      end subroutine explicit_shape

      subroutine pass_array(arr0, arr1, arr2)
      implicit none
      integer, dimension(:,:), intent(in) :: arr0
      integer, dimension(:,:), intent(inout) :: arr1
      integer, dimension(:,:), intent(out) :: arr2

      print *, arr0
      print *, arr1

      arr2 = arr1 + arr0

      end subroutine pass_array

      subroutine pass_5D(arr0, arr1, arr2)
      implicit none
      integer :: i,j,k,l,m
      integer, dimension(:,:,:,:,:), intent(in) :: arr0
      integer, dimension(:,:,:,:,:), intent(inout) :: arr1
      integer, dimension(:,:,:,:,:), intent(out) :: arr2

      print *, shape(arr0)
      print *, shape(arr1)
      print *, shape(arr2)
      ! print *, arr0
      ! print *, arr1

      do i = 1, size(arr0,1)
          do j = 1, size(arr0,2)
              do k = 1, size(arr0,3)
                  do l = 1, size(arr0,4)
                      do m = 1, size(arr0,5)
                          print *, arr0(m,l,k,j,i)
                      enddo
                  enddo
              enddo
          enddo
      enddo

      arr2 = arr1 + arr0

      end subroutine pass_5D

      subroutine pass_3D(arr0, arr1, arr2)
      implicit none
      integer :: i,j,k,l,m
      integer, dimension(:,:,:), intent(in) :: arr0
      integer, dimension(:,:,:), intent(inout) :: arr1
      integer, dimension(:,:,:), intent(out) :: arr2

      print *, shape(arr0)
      print *, shape(arr1)
      print *, shape(arr2)
      ! print *, arr0
      ! print *, arr1

      do k = 1, size(arr0,1)
          do l = 1, size(arr0,2)
              do m = 1, size(arr0,3)
                  print *, arr0(m,l,k)
              enddo
          enddo
      enddo

      arr2 = arr1 + arr0

      end subroutine pass_3D

      subroutine pass_2D(arr0, arr1, arr2)
      implicit none
      integer :: i,j,k,l,m
      integer, dimension(:,:,:), intent(in) :: arr0
      integer, dimension(:,:,:), intent(inout) :: arr1
      integer, dimension(:,:,:), intent(out) :: arr2

      print *, shape(arr0)
      print *, shape(arr1)
      print *, shape(arr2)
      ! print *, arr0
      ! print *, arr1

      do l = 1, size(arr0,1)
          do m = 1, size(arr0,2)
              print *, arr0(m,l,1)
          enddo
      enddo

      arr2 = arr1 + arr0

      end subroutine pass_2D


*> \brief \b SGET40
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGET40( RMAX, LMAX, NINFO, KNT )
*
*       .. Scalar Arguments ..
*       INTEGER            KNT, LMAX, NINFO
*       REAL   RMAX
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGET40 tests STGEXC, a routine for swapping adjacent blocks (either
*> 1 by 1 or 2 by 2) on the diagonal of a pencil in real generalized Schur form.
*> Thus, STGEXC computes an orthogonal matrices Q and Z such that
*>
*>     Q' * ( [ A B ], [ D E ] ) * Z  = ( [ C1 B1 ], [ F1 E1 ] )
*>          ( [ 0 C ]  [   F ] )        ( [ 0  A1 ]  [    D1]  )
*>
*> where (C1,F1) is similar to (C,F) and (A1,D1) is similar to (A,D).
*> Both (A,D) and (C,F) are assumed to be in standard form
*> and (A1,D1) and (C1,F1) are returned with the
*> same properties.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[out] RMAX
*> \verbatim
*>          RMAX is REAL
*>          Value of the largest test ratio.
*> \endverbatim
*>
*> \param[out] LMAX
*> \verbatim
*>          LMAX is INTEGER
*>          Example number where largest test ratio achieved.
*> \endverbatim
*>
*> \param[out] NINFO
*> \verbatim
*>          NINFO is INTEGER
*>          Number of examples where INFO is nonzero.
*> \endverbatim
*>
*> \param[out] KNT
*> \verbatim
*>          KNT is INTEGER
*>          Total number of examples tested.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE SGET40( RMAX, LMAX, NINFO, KNT, NIN )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            KNT, LMAX, NIN
      REAL               RMAX
*     ..
*     .. Array Arguments ..
      INTEGER            NINFO( 3 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
      INTEGER            LDT, LWORK
      PARAMETER          ( LDT = 10, LWORK = 100 + 4*LDT + 16 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
     $                   ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
      REAL               EPS, RES
*     ..
*     .. Local Arrays ..
      REAL               Q( LDT, LDT ), Z( LDT, LDT ), RESULT( 4 ),
     $                   T( LDT, LDT ), T1( LDT, LDT ), T2( LDT, LDT ),
     $                   S( LDT, LDT ), S1( LDT, LDT ), S2( LDT, LDT ),
     $                   TMP( LDT, LDT ), WORK( LWORK )
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGET51, SLACPY, SLASET, STGEXC
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN
*     ..
*     .. Executable Statements ..
*
      EPS = SLAMCH( 'P' )
      RMAX = ZERO
      LMAX = 0
      KNT = 0
      NINFO( 1 ) = 0
      NINFO( 2 ) = 0
      NINFO( 3 ) = 0
*
*     Read input data until N=0
*
   10 CONTINUE
      READ( NIN, FMT = * )N, IFST, ILST
      IF( N.EQ.0 )
     $   RETURN
      KNT = KNT + 1
      DO 20 I = 1, N
         READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
   20 CONTINUE
      CALL SLACPY( 'F', N, N, TMP, LDT, T, LDT )
      CALL SLACPY( 'F', N, N, TMP, LDT, T1, LDT )
      CALL SLACPY( 'F', N, N, TMP, LDT, T2, LDT )
      DO 25 I = 1, N
         READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
   25 CONTINUE
      CALL SLACPY( 'F', N, N, TMP, LDT, S, LDT )
      CALL SLACPY( 'F', N, N, TMP, LDT, S1, LDT )
      CALL SLACPY( 'F', N, N, TMP, LDT, S2, LDT )
      IFSTSV = IFST
      ILSTSV = ILST
      IFST1 = IFST
      ILST1 = ILST
      IFST2 = IFST
      ILST2 = ILST
      RES = ZERO
*
*     Test without accumulating Q and Z
*
      CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
      CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDT )
      CALL STGEXC( .FALSE., .FALSE., N, T1, LDT, S1, LDT, Q, LDT,
     $             Z, LDT, IFST1, ILST1, WORK, LWORK, INFO1 )
      DO 40 I = 1, N
         DO 30 J = 1, N
            IF( I.EQ.J .AND. Q( I, J ).NE.ONE )
     $         RES = RES + ONE / EPS
            IF( I.NE.J .AND. Q( I, J ).NE.ZERO )
     $         RES = RES + ONE / EPS
            IF( I.EQ.J .AND. Z( I, J ).NE.ONE )
     $         RES = RES + ONE / EPS
            IF( I.NE.J .AND. Z( I, J ).NE.ZERO )
     $         RES = RES + ONE / EPS
   30    CONTINUE
   40 CONTINUE
*
*     Test with accumulating Q
*
      CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
      CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDT )
      CALL STGEXC( .TRUE., .TRUE., N, T2, LDT, S2, LDT, Q, LDT,
     $             Z, LDT, IFST2, ILST2, WORK, LWORK, INFO2 )
*
*     Compare T1 with T2 and S1 with S2
*
      DO 60 I = 1, N
         DO 50 J = 1, N
            IF( T1( I, J ).NE.T2( I, J ) )
     $         RES = RES + ONE / EPS
            IF( S1( I, J ).NE.S2( I, J ) )
     $         RES = RES + ONE / EPS
   50    CONTINUE
   60 CONTINUE
      IF( IFST1.NE.IFST2 )
     $   RES = RES + ONE / EPS
      IF( ILST1.NE.ILST2 )
     $   RES = RES + ONE / EPS
      IF( INFO1.NE.INFO2 )
     $   RES = RES + ONE / EPS
*
*     Test orthogonality of Q and Z and backward error on T2 and S2
*
      CALL SGET51( 1, N, T, LDT, T2, LDT, Q, LDT, Z, LDT, WORK,
     $             RESULT( 1 ) )
      CALL SGET51( 1, N, S, LDT, S2, LDT, Q, LDT, Z, LDT, WORK,
     $             RESULT( 2 ) )
      CALL SGET51( 3, N, T, LDT, T2, LDT, Q, LDT, Q, LDT, WORK,
     $             RESULT( 3 ) )
      CALL SGET51( 3, N, T, LDT, T2, LDT, Z, LDT, Z, LDT, WORK,
     $             RESULT( 4 ) )
      RES = RES + RESULT( 1 ) + RESULT( 2 ) + RESULT( 3 ) + RESULT( 4 )
*
*     Read next matrix pair
*
      GO TO 10
*
*     End of SGET40
*
      END


module mod_nodes_uniform
#include <messenger.h>
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: ZERO, ONE, TWO, THREE, FOUR
    use mod_gridspace,  only: linspace
    implicit none

contains

    !>
    !!
    !!
    !!  @author Nathan A. Wukie
    !!  @date   6/28/2017
    !!
    !-------------------------------------------------------------------------------
    function uniform_nodes(level, dim) result(nodes_)
        integer(ik),    intent(in)  :: level
        integer(ik),    intent(in)  :: dim

        ! Level for quadrature nodes corresponds to the number of nodes
        ! in the 1D tensor construction of the node set.
        real(rk),   dimension(level+1)          :: xi_nodes, eta_nodes, zeta_nodes
        integer(ik)                             :: ixi, ieta, izeta, inode, nnodes, ierr, nnodes1d
        integer(ik)                             :: nnodes_xi, nnodes_eta, nnodes_zeta
        real(rk),   allocatable, dimension(:)   :: nodes_(:,:)

        !
        ! Uniform distribution starts with two nodes at end points.
        ! Therefore, minimum level(1) is two points(level+1)
        !
        nnodes1d = level + 1

        !
        ! Get 1D nodes
        !
        select case(dim)
            case(1)
                nnodes_xi   = nnodes1d
                nnodes_eta  = 1
                nnodes_zeta = 1
                xi_nodes    = linspace(-ONE,ONE,nnodes1d)
                eta_nodes   = ZERO
                zeta_nodes  = ZERO
            case(2)
                nnodes_xi   = nnodes1d
                nnodes_eta  = nnodes1d
                nnodes_zeta = 1
                xi_nodes    = linspace(-ONE,ONE,nnodes1d)
                eta_nodes   = linspace(-ONE,ONE,nnodes1d)
                zeta_nodes  = ZERO
            case(3)
                nnodes_xi   = nnodes1d
                nnodes_eta  = nnodes1d
                nnodes_zeta = nnodes1d
                xi_nodes    = linspace(-ONE,ONE,nnodes1d)
                eta_nodes   = linspace(-ONE,ONE,nnodes1d)
                zeta_nodes  = linspace(-ONE,ONE,nnodes1d)
            case default
                call chidg_signal_one(FATAL,"uniform_nodes: invalid dimension.",dim)
        end select

        !
        ! Allocate nodes_
        !
        nnodes = nnodes_xi*nnodes_eta*nnodes_zeta
        allocate(nodes_(nnodes,3), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Contruct node set
        !
        inode = 1
        do izeta = 1,nnodes_zeta
            do ieta = 1,nnodes_eta
                do ixi = 1,nnodes_xi
                    nodes_(inode,1) = xi_nodes(ixi)
                    nodes_(inode,2) = eta_nodes(ieta)
                    nodes_(inode,3) = zeta_nodes(izeta)
                    inode = inode + 1
                end do
            end do
        end do

    end function uniform_nodes
    !***********************************************************************************

    !>
    !!
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/5/2017
    !!
    !-----------------------------------------------------------------------------------
    function uniform_weights(level,dim) result(weights)
        integer(ik),    intent(in)  :: level
        integer(ik),    intent(in)  :: dim

        real(rk),   allocatable :: weights(:), xi_weights(:), eta_weights(:), zeta_weights(:)
        integer(ik)             :: nnodes1d, nweights_xi, nweights_eta, nweights_zeta, nweights, &
                                   inode, ixi, ieta, izeta, ierr

        !
        ! For the node set 'Uniform', the number of nodes in 1D is
        ! defined as (level + 1)
        !
        nnodes1d = level + 1

        !
        ! Get 1D weights
        !
        allocate(xi_weights(nnodes1d), eta_weights(nnodes1d), zeta_weights(nnodes1d), stat=ierr)
        if (ierr /= 0) call AllocationError

        select case(dim)
            case(1)
                nweights_xi   = nnodes1d
                nweights_eta  = 1
                nweights_zeta = 1
                xi_weights    = uniform_weights_1d(nnodes1d)
                eta_weights   = ONE
                zeta_weights  = ONE
            case(2)
                nweights_xi   = nnodes1d
                nweights_eta  = nnodes1d
                nweights_zeta = 1
                xi_weights    = uniform_weights_1d(nnodes1d)
                eta_weights   = uniform_weights_1d(nnodes1d)
                zeta_weights  = ONE
            case(3)
                nweights_xi   = nnodes1d
                nweights_eta  = nnodes1d
                nweights_zeta = nnodes1d
                xi_weights    = uniform_weights_1d(nnodes1d)
                eta_weights   = uniform_weights_1d(nnodes1d)
                zeta_weights  = uniform_weights_1d(nnodes1d)
            case default
                call chidg_signal_one(FATAL,"quadrature_weights: invalid dimension.",dim)
        end select

        !
        ! Allocate weights_
        !
        nweights = nweights_xi*nweights_eta*nweights_zeta
        allocate(weights(nweights), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Contruct node set
        !
        inode = 1
        do izeta = 1,nweights_zeta
            do ieta = 1,nweights_eta
                do ixi = 1,nweights_xi
                    weights(inode) = xi_weights(ixi)*eta_weights(ieta)*zeta_weights(izeta)
                    inode = inode + 1
                end do
            end do
        end do

    end function uniform_weights
    !***********************************************************************************

!    !>
!    !!
!    !!
!    !!  @author Nathan A. Wukie
!    !!  @date   6/28/2017
!    !!
!    !-------------------------------------------------------------------------------
!    function uniform_nodes(level, dim) result(nodes)
!        integer(ik),    intent(in)  :: level
!        integer(ik),    intent(in)  :: dim
!
!        ! Level for quadrature nodes corresponds to the number of nodes
!        ! in the 1D tensor construction of the node set.
!        integer(ik)                 :: inode, inode_inner, nnodes, ierr, &
!                                       nnodes1d, nedge_vertices, nedge_interiors, nface_interiors, &
!                                       nelement_interiors, node_start, node_end, line_begin, line_end
!        real(rk),       allocatable :: nodes(:,:), line_space(:)
!        integer(ik),    allocatable :: nodes_1daccess(:,:), interior_forward(:), interior_reverse(:)
!        logical                     :: duplicate_node
!
!
!        if (dim /= 3) call chidg_signal_one(FATAL,'uniform_nodes: only dim=3 is valid.',dim)
!
!
!        nnodes1d = level+1
!        line_space = linspace(-ONE,ONE,nnodes1d)
!
!        !
!        ! Uniform distribution starts with two nodes at end points.
!        ! Therefore, minimum level(1) is two points(level+1)
!        !
!        nnodes1d = level + 1
!        nnodes = nnodes1d*nnodes1d*nnodes1d
!        allocate(nodes(nnodes,3), stat=ierr)
!        if (ierr /= 0) call AllocationError
!
!
!        ! Get tensor product access indices
!        nodes_1daccess = get_reference_element_1daccess(level)
!
!        ! Check dimensions are correct
!        if (size(nodes_1daccess,1) /= size(nodes,1)) call chidg_signal(FATAL,'uniform_weights: inconsistent node dimensions.')
!
!        ! Assemble nodes
!        do inode = 1,size(nodes,1)
!            nodes(inode,1) = line_space(nodes_1daccess(inode,1))
!            nodes(inode,2) = line_space(nodes_1daccess(inode,2))
!            nodes(inode,3) = line_space(nodes_1daccess(inode,3))
!        end do !inode
!
!
!        ! Check to make sure there are no duplicate nodes
!        do inode = 1,size(nodes,1)
!
!            duplicate_node = .false.
!            do inode_inner = 1,size(nodes,1)
!                if ( (inode /= inode_inner) .and. &
!                     (nodes(inode,1) == nodes(inode_inner,1)) .and. &
!                     (nodes(inode,2) == nodes(inode_inner,2)) .and. &
!                     (nodes(inode,3) == nodes(inode_inner,3)) &
!                    ) then
!                    duplicate_node = .true.
!                end if
!            end do !inode_inner
!
!            if (duplicate_node) call chidg_signal(FATAL,'uniform_nodes: found duplicate node. Must be error in node set convention.')
!
!        end do !inode
!
!
!
!
!    end function uniform_nodes
!    !***********************************************************************************
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!    !>
!    !!
!    !!
!    !!  @author Nathan A. Wukie (AFRL)
!    !!  @date   7/5/2017
!    !!
!    !-----------------------------------------------------------------------------------
!    function uniform_weights(level,dim) result(weights)
!        integer(ik),    intent(in)  :: level
!        integer(ik),    intent(in)  :: dim
!
!        real(rk),       allocatable :: weights(:), line_weights(:)
!        integer(ik),    allocatable :: nodes_1daccess(:,:)
!        integer(ik)                 :: nnodes1d, nweights_xi, nweights_eta, nweights_zeta, nweights, &
!                                       inode, ierr, iweight
!
!        ! For the node set 'Uniform', the number of nodes in 1D is
!        ! defined as (level + 1)
!        nnodes1d = level + 1
!
!
!        ! Get line weights
!        line_weights = uniform_weights_1d(nnodes1d)
!
!        ! Get tensor product access indices
!        nodes_1daccess = get_reference_element_1daccess(level)
!
!        ! Specialize for
!        select case(dim)
!            case(3)
!                nweights_xi   = nnodes1d
!                nweights_eta  = nnodes1d
!                nweights_zeta = nnodes1d
!            case default
!                call chidg_signal_one(FATAL,"quadrature_weights: invalid dimension.",dim)
!        end select
!
!        ! Allocate weights_
!        nweights = nweights_xi*nweights_eta*nweights_zeta
!        allocate(weights(nweights), stat=ierr)
!        if (ierr /= 0) call AllocationError
!
!
!        ! Check dimensions are correct
!        if (size(nodes_1daccess,1) /= size(weights)) call chidg_signal(FATAL,'uniform_weights: inconsistent node dimensions.')
!
!
!        ! Assemble tensor product weights
!        do iweight = 1,size(weights)
!            weights(iweight) = line_weights(nodes_1daccess(iweight,1)) * &
!                               line_weights(nodes_1daccess(iweight,2)) * &
!                               line_weights(nodes_1daccess(iweight,3))
!        end do !iweight
!
!    end function uniform_weights
!    !***********************************************************************************
!
!
!
!
!
!
!
!
!
!
!    !>
!    !!
!    !!  @author Nathan A. Wukie
!    !!  @date   8/1/2019
!    !!
!    !----------------------------------------------------------------------------------
!    function get_reference_element_1daccess(order) result(nodes_1daccess)
!        integer(ik),    intent(in)  :: order
!
!        integer(ik)                 :: nedge_vertices, nedge_interiors, nface_interiors, nelement_interiors, &
!                                       line_begin, line_end, node_start, node_end, nnodes, nnodes1d, ierr, inode, inode_inner
!        integer(ik),    allocatable :: nodes_1daccess(:,:), interior_forward(:), interior_reverse(:)
!        logical :: duplicate_node
!
!
!        nnodes1d = order+1
!        nnodes = nnodes1d*nnodes1d*nnodes1d
!        allocate(nodes_1daccess(nnodes,3), stat=ierr)
!        if (ierr /= 0) call AllocationError
!
!
!        !
!        ! Fill edge, face, interior nodes
!        !
!        select case (order)
!            ! Quadratic (HEXA_27)
!            case(2)
!                nedge_vertices     = 2
!                nedge_interiors    = 1
!                nface_interiors    = 1
!                nelement_interiors = 1
!                line_begin = 1
!                line_end  = nedge_interiors+nedge_vertices
!                interior_forward = [2]
!                interior_reverse = [2]
!
!
!
!
!                ! Hex vertices are same for all orders
!                nodes_1daccess(1,1) = line_begin
!                nodes_1daccess(1,2) = line_begin
!                nodes_1daccess(1,3) = line_begin
!
!                nodes_1daccess(2,1) = line_end
!                nodes_1daccess(2,2) = line_begin
!                nodes_1daccess(2,3) = line_begin
!
!                nodes_1daccess(3,1) = line_end
!                nodes_1daccess(3,2) = line_end
!                nodes_1daccess(3,3) = line_begin
!
!                nodes_1daccess(4,1) = line_begin
!                nodes_1daccess(4,2) = line_end
!                nodes_1daccess(4,3) = line_begin
!
!                nodes_1daccess(5,1) = line_begin
!                nodes_1daccess(5,2) = line_begin
!                nodes_1daccess(5,3) = line_end
!
!                nodes_1daccess(6,1) = line_end
!                nodes_1daccess(6,2) = line_begin
!                nodes_1daccess(6,3) = line_end
!
!                nodes_1daccess(7,1) = line_end
!                nodes_1daccess(7,2) = line_end
!                nodes_1daccess(7,3) = line_end
!
!                nodes_1daccess(8,1) = line_begin
!                nodes_1daccess(8,2) = line_end
!                nodes_1daccess(8,3) = line_end
!
!
!
!
!
!
!
!
!
!
!
!                ! Edge interiors
!
!                !* Edge 1
!                node_start = 9
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_forward
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 2
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = interior_forward
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 3
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_reverse
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 4
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = interior_reverse
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 5
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 6
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 7
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 8
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 9
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_forward
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 10
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = interior_forward
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 11
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_reverse
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 12
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = interior_reverse
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!
!
!                ! Face interiors
!
!                ! Face 1
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end,1) = 2
!                nodes_1daccess(node_start:node_end,2) = 2
!                nodes_1daccess(node_start:node_end,3) = line_begin
!
!                ! Face 2
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end,1) = 2
!                nodes_1daccess(node_start:node_end,2) = line_begin
!                nodes_1daccess(node_start:node_end,3) = 2
!
!                ! Face 3
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end,1) = line_end
!                nodes_1daccess(node_start:node_end,2) = 2
!                nodes_1daccess(node_start:node_end,3) = 2
!
!                ! Face 4
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end,1) = 2
!                nodes_1daccess(node_start:node_end,2) = line_end
!                nodes_1daccess(node_start:node_end,3) = 2
!
!                ! Face 5
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end,1) = line_begin
!                nodes_1daccess(node_start:node_end,2) = 2
!                nodes_1daccess(node_start:node_end,3) = 2
!
!                ! Face 6
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end,1) = 2
!                nodes_1daccess(node_start:node_end,2) = 2
!                nodes_1daccess(node_start:node_end,3) = line_end
!
!                !* Interior
!                node_start = node_end+1
!                node_end   = node_start+nelement_interiors-1
!                nodes_1daccess(node_start:node_end,1) = 2
!                nodes_1daccess(node_start:node_end,2) = 2
!                nodes_1daccess(node_start:node_end,3) = 2
!
!
!
!            ! Cubic (HEXA_64)
!            case(3)
!
!                nedge_vertices     = 2
!                nedge_interiors    = 2
!                nface_interiors    = 4
!                nelement_interiors = 8
!                line_begin = 1
!                line_end  = nedge_interiors+nedge_vertices
!                interior_forward = [2,3]
!                interior_reverse = [3,2]
!
!
!
!                ! Hex vertices are same for all orders
!                nodes_1daccess(1,1) = line_begin
!                nodes_1daccess(1,2) = line_begin
!                nodes_1daccess(1,3) = line_begin
!
!                nodes_1daccess(2,1) = line_end
!                nodes_1daccess(2,2) = line_begin
!                nodes_1daccess(2,3) = line_begin
!
!                nodes_1daccess(3,1) = line_end
!                nodes_1daccess(3,2) = line_end
!                nodes_1daccess(3,3) = line_begin
!
!                nodes_1daccess(4,1) = line_begin
!                nodes_1daccess(4,2) = line_end
!                nodes_1daccess(4,3) = line_begin
!
!                nodes_1daccess(5,1) = line_begin
!                nodes_1daccess(5,2) = line_begin
!                nodes_1daccess(5,3) = line_end
!
!                nodes_1daccess(6,1) = line_end
!                nodes_1daccess(6,2) = line_begin
!                nodes_1daccess(6,3) = line_end
!
!                nodes_1daccess(7,1) = line_end
!                nodes_1daccess(7,2) = line_end
!                nodes_1daccess(7,3) = line_end
!
!                nodes_1daccess(8,1) = line_begin
!                nodes_1daccess(8,2) = line_end
!                nodes_1daccess(8,3) = line_end
!
!
!
!
!
!
!
!
!
!                ! Edge interiors
!                !* Edge 1
!                node_start = 9
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_forward
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 2
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = interior_forward
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 3
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_reverse
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 4
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = interior_reverse
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 5
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 6
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 7
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 8
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 9
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_forward
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 10
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = interior_forward
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 11
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_reverse
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 12
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = interior_reverse
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!
!
!                !* Face 1
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [2, 3, 3, 2]
!                nodes_1daccess(node_start:node_end, 2) = [2, 2, 3, 3]
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Face 2
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [2, 3, 3, 2]
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 3, 3]
!
!                !* Face 3
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = [2, 3, 3, 2]
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 3, 3]
!
!                !* Face 4
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [3, 2, 2, 3]
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 3, 3]
!
!                !* Face 5
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = [3, 2, 2, 3]
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 3, 3]
!
!                !* Face 6
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [2, 3, 3, 2]
!                nodes_1daccess(node_start:node_end, 2) = [2, 2, 3, 3]
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Interior
!                node_start = node_end+1
!                node_end   = node_start+nelement_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [2, 3, 3, 2, 2, 3, 3, 2]
!                nodes_1daccess(node_start:node_end, 2) = [2, 2, 3, 3, 2, 2, 3, 3]
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 2, 2, 3, 3, 3, 3]
!
!
!
!            ! Quartic (HEXA_125)
!            case(4)
!
!                nedge_vertices     = 2
!                nedge_interiors    = 3
!                nface_interiors    = 9
!                nelement_interiors = 27
!                line_begin = 1
!                line_end  = nedge_interiors+nedge_vertices
!                interior_forward = [2,3,4]
!                interior_reverse = [4,3,2]
!
!
!
!                ! Hex vertices are same for all orders
!                nodes_1daccess(1,1) = line_begin
!                nodes_1daccess(1,2) = line_begin
!                nodes_1daccess(1,3) = line_begin
!
!                nodes_1daccess(2,1) = line_end
!                nodes_1daccess(2,2) = line_begin
!                nodes_1daccess(2,3) = line_begin
!
!                nodes_1daccess(3,1) = line_end
!                nodes_1daccess(3,2) = line_end
!                nodes_1daccess(3,3) = line_begin
!
!                nodes_1daccess(4,1) = line_begin
!                nodes_1daccess(4,2) = line_end
!                nodes_1daccess(4,3) = line_begin
!
!                nodes_1daccess(5,1) = line_begin
!                nodes_1daccess(5,2) = line_begin
!                nodes_1daccess(5,3) = line_end
!
!                nodes_1daccess(6,1) = line_end
!                nodes_1daccess(6,2) = line_begin
!                nodes_1daccess(6,3) = line_end
!
!                nodes_1daccess(7,1) = line_end
!                nodes_1daccess(7,2) = line_end
!                nodes_1daccess(7,3) = line_end
!
!                nodes_1daccess(8,1) = line_begin
!                nodes_1daccess(8,2) = line_end
!                nodes_1daccess(8,3) = line_end
!
!
!
!
!
!
!
!
!
!
!
!                ! Edge interiors
!                !* Edge 1
!                node_start = 9
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_forward
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 2
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = interior_forward
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 3
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_reverse
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 4
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = interior_reverse
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!                !* Edge 5
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 6
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 7
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 8
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = interior_forward
!
!                !* Edge 9
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_forward
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 10
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = interior_forward
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 11
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = interior_reverse
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Edge 12
!                node_start = node_end+1
!                node_end   = node_start+nedge_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = interior_reverse
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!
!
!                !* Face 1
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [2, 3, 4, 4, 4, &
!                                                          3, 2, 2, 3]
!                nodes_1daccess(node_start:node_end, 2) = [2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3]
!                nodes_1daccess(node_start:node_end, 3) = line_begin
!
!
!                !* Face 2
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [2, 3, 4, 4, 4, &
!                                                          3, 2, 2, 3]
!                nodes_1daccess(node_start:node_end, 2) = line_begin
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3]
!
!                !* Face 3
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_end
!                nodes_1daccess(node_start:node_end, 2) = [2, 3, 4, 4, 4, &
!                                                          3, 2, 2, 3]
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3]
!
!                !* Face 4
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [4, 3, 2, 2, 2, &
!                                                          3, 4, 4, 3]
!                nodes_1daccess(node_start:node_end, 2) = line_end
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3]
!
!                !* Face 5
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = line_begin
!                nodes_1daccess(node_start:node_end, 2) = [4, 3, 2, 2, 2, &
!                                                          3, 4, 4, 3]
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3]
!
!                !* Face 6
!                node_start = node_end+1
!                node_end   = node_start+nface_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [2, 3, 4, 4, 4, &
!                                                          3, 2, 2, 3]
!                nodes_1daccess(node_start:node_end, 2) = [2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3]
!                nodes_1daccess(node_start:node_end, 3) = line_end
!
!                !* Interior
!                node_start = node_end+1
!                node_end   = node_start+nelement_interiors-1
!                nodes_1daccess(node_start:node_end, 1) = [2, 3, 4, 4, 4, &
!                                                          3, 2, 2, 3,    &
!                                                          2, 3, 4, 4, 4, &
!                                                          3, 2, 2, 3,    &
!                                                          2, 3, 4, 4, 4, &
!                                                          3, 2, 2, 3]
!                nodes_1daccess(node_start:node_end, 2) = [2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3,    &
!                                                          2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3,    &
!                                                          2, 2, 2, 3, 4, &
!                                                          4, 4, 3, 3]
!                nodes_1daccess(node_start:node_end, 3) = [2, 2, 2, &
!                                                          2, 2, 2, &
!                                                          2, 2, 2, &
!                                                          3, 3, 3, &
!                                                          3, 3, 3, &
!                                                          3, 3, 3, &
!                                                          4, 4, 4, &
!                                                          4, 4, 4, &
!                                                          4, 4, 4]
!
!
!
!
!            case default
!                call chidg_signal_one(FATAL,"uniform_nodes: invalid value for 'level'", order)
!
!        end select
!
!
!        ! Check access indices are all unique
!        do inode = 1,size(nodes_1daccess,1)
!            duplicate_node = .false.
!            do inode_inner = 1,size(nodes_1daccess,1)
!                if ( (inode /= inode_inner) .and. &
!                     (nodes_1daccess(inode,1) == nodes_1daccess(inode_inner,1)) .and. &
!                     (nodes_1daccess(inode,2) == nodes_1daccess(inode_inner,2)) .and. &
!                     (nodes_1daccess(inode,3) == nodes_1daccess(inode_inner,3)) ) then
!                     duplicate_node = .true.
!                end if
!            end do
!            if (duplicate_node) call chidg_signal(FATAL,'get_reference_element_1daccess: duplicate node detected.')
!        end do
!
!
!
!    end function get_reference_element_1daccess
!    !**********************************************************************************

    !>  Compute quadrature weights for a 1D uniform node distribution between [-1,1].
    !!
    !!  Even number of nodes: Composite Trapezoid rule (less accurate)
    !!  Odd number of nodes:  Composite Simpson's rule (more accurate)
    !!
    !!
    !!  NOTE: An odd number of nodes should always be preferred, since the Composite
    !!        Simpson's rule is much more accurate than the Composite Trapezoid rule.
    !!
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/5/2017
    !!
    !------------------------------------------------------------------------------------
    function uniform_weights_1d(nnodes1d) result(weights)
        integer(ik),    intent(in)  :: nnodes1d

        real(rk)    :: weights(nnodes1d)
        integer(ik) :: inode
        logical     :: even, even_node

        ! determin odd/even
        even = (mod(nnodes1d,2) == 0)

        !
        ! EVEN: Composite Trapezoid rule
        !   int_a^b[f]dx = h/2[f(x0) + 2f(x1) + 2f(x2) + ... + 2f(x_{n-1}) + f(xn)]
        !   Weights computed for x in [-1,1]. h=2
        !
        if (even) then
            weights(1)        = ONE ! f(x0)
            weights(nnodes1d) = ONE ! f(xn)

            if (nnodes1d > 2) then
                do inode = 2,nnodes1d-1
                    weights(inode) = TWO
                end do !inode
            end if

        !
        ! ODD: Composite Simpson's rule
        !   int_a^b[f]dx = h/3[f(x0) + 4f(x1) + 2f(x2) + 4f(x3) + 2f(x4) + ... + 4f(x_{n-1}) + f(xn)]
        !   Weights computed for x in [-1,1]. h=2
        !
        else
            weights(1)        = TWO/THREE   ! f(x0)
            weights(nnodes1d) = TWO/THREE   ! f(xn)

            do inode = 2,nnodes1d-1
                even_node = (mod(inode,2) == 0)
                if (even_node) then
                    weights(inode) = (TWO/THREE)*FOUR
                else
                    weights(inode) = (TWO/THREE)*TWO
                end if
            end do !inode

        end if

    end function uniform_weights_1d
    !************************************************************************************

end module mod_nodes_uniform


      SUBROUTINE SUBBAK ( W, NROW, NCOL, LAST, X )
C
C*********************************************************************
C
C     carries out backsubstitution for current block.
C
C    parameters
C       w, ipivot, nrow, ncol, last  are as on return from factrb.
C       x(1),...,x(ncol)  contains, on input, the right side for the
C               equations in this block after backsubstitution has been
C               carried up to but not including equation (last).
C               means that x(j) contains the right side of equation (j)
C               as modified during elimination, j=1,...,last, while
C               for j .gt. last, x(j) is already a component of the
C               solution vector.
C       x(1),...,x(ncol) contains, on output, the components of the
C               solution corresponding to the present block.
C
C*********************************************************************
C
      INTEGER  LAST,  I,J,K,KM1,LM1,LP1
      DOUBLE PRECISION W(NROW,NCOL),X(NCOL), T
C
      LP1 = LAST + 1
      IF ( LP1 .GT. NCOL )                          GO TO 30
      DO 20 J = LP1, NCOL
         T = - X(J)
         IF ( T .EQ. 0.D0 )                         GO TO 20
         DO 10 I = 1, LAST
   10       X(I) = X(I) + W(I,J) * T
   20 CONTINUE
   30 IF ( LAST .EQ. 1 )                            GO TO 60
      LM1 = LAST - 1
      DO 50 KB = 1, LM1
        KM1 = LAST - KB
        K = KM1 + 1
        X(K) = X(K)/W(K,K)
        T = - X(K)
        IF ( T .EQ. 0.D0 )                          GO TO 50
        DO 40 I = 1, KM1
   40     X(I) = X(I) + W(I,K) * T
   50 CONTINUE
   60 X(1) = X(1)/W(1,1)
      RETURN
      END


************************************************************************
*
*     Function IDAMAX                                  Called by: DGEFA
*
*     find the index of element having maximum absolute value.  Based
*     on a LINPACK routine written by Jack Dongarra.
*
*     for the special case of INCX=1
*
************************************************************************
      INTEGER*4 FUNCTION IDAMAX(N,DX)
*
*     function arguments
*
      INTEGER*4 N
      DOUBLE PRECISION DX(*)
*
*     local vars
*
      DOUBLE PRECISION DMAX
      INTEGER*4 I,IX

      IDAMAX = 0
      DMAX = 0.D0
      DO 10 I=1,N
         IF (DABS(DX(I)).GT.DMAX) THEN
            IDAMAX = I
            DMAX = DABS(DX(I))
         ENDIF
   10 CONTINUE

      RETURN
      END


      subroutine foo(f1,f2,f3,f4,f5,f6,f7,f8,f9,f0,g1,g2,g3)
      implicit none
      integer f4,f3,f2,f1
      integer g4,g5,g6,g7,g8,g9
      integer i1,i2,i3,i4,i5

      real*8 g1(f4,f3,f2,f1),g2(f4,f4,f3,f2,f1),g3(f4,f3,f2,f1)
      real*8 f0(f4,f4,f3,f2,f1),f9(f4,f4,f3,f2,f1),f8(f4,f4,f3,f2,f1)
      real*8 f7(f4,f4,f3,f2,f1),f6(f4,f4,f3,f2,f1),f5(f4,f4,f3,f2,f1)

      do i3=1,f1
         g8=mod(i3+f1-2,f1)+1
         g9=mod(i3,f1)+1
         do i4=1,f2
            g6=mod(i4+f2-2,f2)+1
            g7=mod(i4,f2)+1
            do i5=1,f3
               g4=mod(i5+f3-2,f3)+1
               g5=mod(i5,f3)+1
               do i1=1,f4
                  g3(i1,i5,i4,i3)=0.0d0
                  do i2=1,f4
                     g3(i1,i5,i4,i3)=g3(i1,i5,i4,i3)+
     1                    g2(i1,i2,i5,i4,i3)*g1(i2,i5,i4,i3)+
     2                    f0(i1,i2,i5,i4,i3)*g1(i2,g5,i4,i3)+
     3                    f9(i1,i2,i5,i4,i3)*g1(i2,i5,g7,i3)+
     4                    f8(i1,i2,i5,i4,i3)*g1(i2,i5,i4,g9)+
     5                    f7(i1,i2,i5,i4,i3)*g1(i2,g4,i4,i3)+
     6                    f6(i1,i2,i5,i4,i3)*g1(i2,i5,g6,i3)+
     7                    f5(i1,i2,i5,i4,i3)*g1(i2,i5,i4,g8)
                  enddo
               enddo
            enddo
         enddo
      enddo
      return
      end

! This is the kernel extracted from bwaves: this cannot be interchanged
! as the number of iterations for f4 is not known.

! { dg-final { scan-tree-dump-times "will be interchanged" 0 "graphite" } }
! { dg-final { cleanup-tree-dump "graphite" } }


      program DRZGAM
c>> 2001-05-22 DRZGAM Krogh Minor change for making .f90 version.
c>> 1996-06-14 DRZGAM Krogh Changes for C conversion.
c>> 1994-08-17 CLL
c>> 1991-10-18 Demo driver for ZGAM
c     ------------------------------------------------------------------
c--   D version uses DRZGAM, ZGAM
c--   S version uses DRCGAM, CGAM
c     ------------------------------------------------------------------
      double precision ARG(2),GAM(2),LGAM(2), X(2,8)
      double precision ERR0, ERR1
      integer I, J
      data ( ( X(I,J),I=1,2 ), J=1,8 ) /
     * 1.0D0,0.0D0, 1.0D0,0.5D0, 1.5D0,0.0D0, 1.5D0,0.5D0,
     * 0.0D0,0.5D0, -1.5D0,0.5D0,  -1.5D0,0.0D0,  -1.5D0,-0.5D0 /
c     ------------------------------------------------------------------
      print '(5x,''X          GAMMA        Err Est'', 11x,
     * ''LGAMA         Err Est'')'
c
      do 10 J = 1,8
        ARG(1) = X(1,J)
        ARG(2) = X(2,J)
        call ZGAM (ARG,GAM,ERR1,1)
        call ZGAM (ARG,LGAM,ERR0,0)
        print
     *  '(1x,f5.1,g20.10,g10.2,g22.10,g10.2/1x,f5.1,g20.10,g32.10/)',
     *        ARG(1),GAM(1),ERR1, LGAM(1), ERR0,
     *        ARG(2),GAM(2),      LGAM(2)
  10  continue
      end


      REAL             FUNCTION STZT01( M, N, A, AF, LDA, TAU, WORK,
     $                 LWORK )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), AF( LDA, * ), TAU( * ),
     $                   WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  STZT01 returns
*       || A - R*Q || / ( M * eps * ||A|| )
*  for an upper trapezoidal A that was factored with STZRQF.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrices A and AF.
*
*  N       (input) INTEGER
*          The number of columns of the matrices A and AF.
*
*  A       (input) REAL array, dimension (LDA,N)
*          The original upper trapezoidal M by N matrix A.
*
*  AF      (input) REAL array, dimension (LDA,N)
*          The output of STZRQF for input matrix A.
*          The lower triangle is not referenced.
*
*  LDA     (input) INTEGER
*          The leading dimension of the arrays A and AF.
*
*  TAU     (input) REAL array, dimension (M)
*          Details of the  Householder transformations as returned by
*          STZRQF.
*
*  WORK    (workspace) REAL array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          The length of the array WORK.  LWORK >= m*n + m.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      REAL               NORMA
*     ..
*     .. Local Arrays ..
      REAL               RWORK( 1 )
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLANGE
      EXTERNAL           SLAMCH, SLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           SAXPY, SLATZM, SLASET, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, REAL
*     ..
*     .. Executable Statements ..
*
      STZT01 = ZERO
*
      IF( LWORK.LT.M*N+M ) THEN
         CALL XERBLA( 'STZT01', 8 )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
      NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK )
*
*     Copy upper triangle R
*
      CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
      DO 20 J = 1, M
         DO 10 I = 1, J
            WORK( ( J-1 )*M+I ) = AF( I, J )
   10    CONTINUE
   20 CONTINUE
*
*     R = R * P(1) * ... *P(m)
*
      DO 30 I = 1, M
         CALL SLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ),
     $                WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M,
     $                WORK( M*N+1 ) )
   30 CONTINUE
*
*     R = R - A
*
      DO 40 I = 1, N
         CALL SAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 )
   40 CONTINUE
*
      STZT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK )
*
      STZT01 = STZT01 / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
      IF( NORMA.NE.ZERO )
     $   STZT01 = STZT01 / NORMA
*
      RETURN
*
*     End of STZT01
*
      END


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module linear_combine_two_states

  use definitions, only: t_state,wp,t_grid

  implicit none

  private

  public :: lin_combination
  public :: interpolation_t

  contains

  subroutine lin_combination(state_0,state_1,state_out,coeff_0,coeff_1,grid)

    ! this performs a linear combination of two states

    type(t_state), intent(in)    :: state_0
    type(t_state), intent(in)    :: state_1
    type(t_state), intent(inout) :: state_out
    real(wp),      intent(in)    :: coeff_0
    real(wp),      intent(in)    :: coeff_1
    type(t_grid),  intent(in)    :: grid

    state_out%rho        = coeff_0*state_0%rho              + coeff_1*state_1%rho
    state_out%rhotheta   = coeff_0*state_0%rhotheta         + coeff_1*state_1%rhotheta
    state_out%theta_pert = state_out%rhotheta/state_out%rho - grid%theta_bg
    state_out%exner_pert = coeff_0*state_0%exner_pert       + coeff_1*state_1%exner_pert
    state_out%wind_u     = coeff_0*state_0%wind_u           + coeff_1*state_1%wind_u
    state_out%wind_v     = coeff_0*state_0%wind_v           + coeff_1*state_1%wind_v
    state_out%wind_w     = coeff_0*state_0%wind_w           + coeff_1*state_1%wind_w

  end subroutine lin_combination

  subroutine interpolation_t(state_0,state_1,state_out,time_old,time_new,time_write,grid)

    ! this performs an interpolation in time

    type(t_state), intent(in)    :: state_0
    type(t_state), intent(in)    :: state_1
    type(t_state), intent(inout) :: state_out
    real(wp),      intent(in)    :: time_old
    real(wp),      intent(in)    :: time_new
    real(wp),      intent(in)    :: time_write
    type(t_grid),  intent(in)    :: grid

    call lin_combination(state_0,state_1,state_out,1._wp-(time_write-time_old)/(time_new-time_old), &
    (time_write-time_old)/(time_new-time_old),grid)

  end subroutine interpolation_t

end module linear_combine_two_states


      subroutine breitw(x1,mminsq,mmaxsq,rmass,rwidth,msq,wt)
      implicit none
      include 'constants.f'
c---- Given a number 0<x<1 generate a mass-squared msq and a weight wt
c---- such that mminsq<msq<mmaxsq
c---- points are generated around resonance position rmass, but
c---- breit-wigner should still be included in the matrix element
c     wt is the jacobian between integration in msq and integration in x1
      double precision x1,mminsq,mmaxsq,rmass,rwidth,msq,wt
      double precision almin,almax,al,tanal
      include 'zerowidth.f'

c--- in case the maximum msq is very small, just generate linearly for safety
      if ((mmaxsq .lt. rmass*1d-3) .and. (zerowidth .eqv. .false.)) then
        msq=mminsq+x1*(mmaxsq-mminsq)
        wt=mmaxsq-mminsq
        return
      endif

      if (zerowidth) then
          tanal=0d0
          almax=+pi/two
          almin=-pi/two
      else
          almin=datan((mminsq-rmass**2)/rmass/rwidth)
          almax=datan((mmaxsq-rmass**2)/rmass/rwidth)
          al=(almax-almin)*x1+almin
          tanal=dtan(al)
      endif

      msq=rmass**2+rmass*rwidth*tanal
c---- bw=(1d0+tanal**2)*rmass**2*rwidth**2
      wt=(almax-almin)*rmass*rwidth*(1d0+tanal**2)

      if (msq .lt. 0d0) then
        msq=mminsq
        wt=0d0
      endif

      return
      end


! =====================================================
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr, &
                aux1,aux2,aux3,asdq,bmasdq,bpasdq)
! =====================================================

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                           !
!      # This Riemann solver is for the shallow water adjoint               !
!             equations. It is similar to rpt2_vc_acoustics.f90
!
!      # See rpn2_geoclaw_adjoint_qwave.f90 for the equations and discussion!
!                                                                           !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     # Split asdq into down-going flux bmasdq and up-going flux bpasdq.
!     # imp=1  means  asdq=amdq,    imp=2 means asdq=apdq

    use geoclaw_module, only: g => grav, drytol => dry_tolerance
    use geoclaw_module, only: coordinate_system,earth_radius,deg2rad

    implicit none

    integer, intent(in) :: ixy,imp,maxm,meqn,mwaves,maux,mbc,mx
    real(kind=8), intent(in) ::    ql(meqn, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) ::    qr(meqn, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) ::    asdq(meqn, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) ::   aux1(maux, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) ::   aux2(maux, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) ::   aux3(maux, 1-mbc:maxm+mbc)
    real(kind=8), intent(out) :: bmasdq(meqn, 1-mbc:maxm+mbc)
    real(kind=8), intent(out) :: bpasdq(meqn, 1-mbc:maxm+mbc)

!   local:
    integer :: i,mu,mv,i1
    real(kind=8) :: h0D,h00,h0U,bD,b0,bU,c0,cU,cD,a1,a2,dxdcU,dxdcD,s1,s2

!   # initialize for dry state cells:
    bmasdq = 0.d0
    bpasdq = 0.d0

    if (ixy == 1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

    do i = 2-mbc, mx+mbc

         if (maxval(abs(asdq(:,i))) == 0.d0) then
            cycle  ! go to next i
            endif

!        # imp is used to flag whether wave is going to left or right,
!        # since material properties are different on the two sides

        if (imp == 1) then
!            # asdq = amdq, moving to left
            i1 = i-1
        else
!            # asdq = apdq, moving to right
            i1 = i
        endif

!       # The flux difference asdq is split into downward moving part
!       # traveling at speed -cD relative to the medium below and
!       # an upward moving part traveling
!       # at speed +cU relative to the medium above.

!       # Note that the sum of these parts does not give all of asdq
!       # since there is also reflection at the interfaces which decreases
!       # the flux.

!       # gravity wave speed in each row of cells:

        ! background depth based on topography:
        bD = aux1(1,i1)
        b0 = aux2(1,i1)
        bU = aux3(1,i1)
        h0U = max(-bU, 0.d0)
        h00 = max(-b0, 0.d0)
        h0D = max(-bD, 0.d0)
        cD = sqrt(g*h0D)
        c0 = sqrt(g*h00)
        cU = sqrt(g*h0U)

        if (h00 < drytol) then
            cycle  ! no waves in this cell
            endif

!       # transmitted part of down-going wave:
        if (h0D < drytol) then
            a1 = 0.d0  ! no transmitted wave
        else
            a1 = (asdq(1,i) + asdq(mv,i)*c0) / (c0 + cD)
        endif

!       # transmitted part of up-going wave:
        if (h0U < drytol) then
            a2 = 0.d0  ! no transmitted wave
        else
            a2 = (-asdq(1,i) + asdq(mv,i)*c0) / (c0 + cU)
        endif

        !====== Adjust for mapping from latitude longitude to physical space====
        if (coordinate_system.eq.2) then
           if (ixy.eq.2) then
               dxdcU=(earth_radius*deg2rad)
               dxdcD = dxdcU
           else
               dxdcU = earth_radius*cos(aux3(3,i1))*deg2rad
               dxdcD = earth_radius*cos(aux1(3,i1))*deg2rad
           endif
        else
            dxdcU = 1.d0
            dxdcD = 1.d0
        endif

!       # The down-going flux difference bmasdq is the product  -cD * wave1
!       # down-going eigenvector of -A(x)^T is r1 = [cD, 1]^T

        s1 = -cD * dxdcD  ! adjusted down-going wave speed
        bmasdq(1,i) = s1 * a1*cD
        bmasdq(mu,i) = 0.d0
        bmasdq(mv,i) = s1 * a1

!       # The up-going flux difference bpasdq is the product  cU * wave2
!       # up-going eigenvector of -A(x)^T is r2 = [-cU, 1]^T

        s2 = cU * dxdcU  ! adjusted up-going wave speed
        bpasdq(1,i) = s2 * a2*(-cU)
        bpasdq(mu,i) = 0.d0
        bpasdq(mv,i) = s2 * a2

        enddo

    return
    end subroutine rpt2


!-----subroutine---------------------------------------------g.guidati--
!
subroutine CDA0   (sworkat, yc1at, yc2at, d2yc1at, d2yc2at,na, ng, td, Ad, pi2i, kwave, herm1, herm2, herm3, herm4 )
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             calculate the two dimensional influences of
!                       a doublet with distribution according to
!                       hermite polynomials
!
!.......................................................................
!               declarations
!.......................................................................
      USE TINoiseDDD
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: na,k,ng,nok,nbad
INTEGER(4)                   :: khi
INTEGER(4)                   :: klo
INTEGER(4)                   :: nvar

REAL(DbKi)                   :: kwave,kwave2
REAL(DbKi)                   :: smid
REAL(DbKi)                   :: y1cent
REAL(DbKi)                   :: y2cent
REAL(DbKi)                   :: d1y1,d1y2,pi2i
REAL(DbKi)                   :: raver,sloc,s,wgtd,y1,y2,r2,arg
REAL(DbKi)                   :: eps
REAL(DbKi)                   :: h1
REAL(DbKi)                   :: hmin
REAL(DbKi)                   :: sworkat(na+1), yc1at(na+1), yc2at(na+1), ystart(8)
REAL(DbKi)                   :: d2yc1at(na+1), d2yc2at(na+1), td(4,4), Ad(4,4)

COMPLEX(DbKi)                :: herm1
COMPLEX(DbKi)                :: herm2
COMPLEX(DbKi)                :: herm3
COMPLEX(DbKi)                :: herm4
COMPLEX(DbKi)                :: HANK1,green

EXTERNAL         :: HANK1
EXTERNAL         :: CDA0_f, rkqs
!.......................................................................
!
!.......................................................................
      nvar    =  8
      eps     =  1.0D-05
      h1      =  0.1
      hmin    =  0.0
!.......................................................................
!               calculate influence by gaussian quadrature
!.......................................................................

herm1 = 0.0
herm2 = 0.0
herm3 = 0.0
herm4 = 0.0

      smid = (s1 + s2) / 2.0d0
      call SPL_EX  (sworkat,na+1,smid,khi,klo)
      call SPL_EX1 (sworkat,yc1at,d2yc1at,na+1,smid,y1cent,d1y1,khi,klo)
      call SPL_EX1 (sworkat,yc2at,d2yc2at,na+1,smid,y2cent,d1y2,khi,klo)

      raver = ((x1 - y1cent)**2 + (x2 - y2cent)**2) / (s2-s1)**2

!      write(*,*) raver
      if(raver.gt.2000000.0d0) then

	write(*,*) 'GROTTEFALSCH!'
	stop

        do k=1,ng

          sloc = td(k,ng)
          s = (s1 + s2) / 2.0d0 + td(k,ng) * (s2 - s1) / 2.0d0
          wgtd = Ad(k,ng) * (s2 - s1) / 2.0d0
          call SPL_EX  (sworkat,na+1,s,khi,klo)
          call SPL_EX1 (sworkat,yc1at,d2yc1at,na+1,s,y1,d1y1,khi,klo)
          call SPL_EX1 (sworkat,yc2at,d2yc2at,na+1,s,y2,d1y2,khi,klo)

!          write(36,*) y1,y2

          r2 = (x1 - y1) ** 2.0d0 + (x2 - y2) ** 2.0d0
          arg = r2 * kwave2

          green = (0.0d0,1.0d0)/4.0d0 * (kwave)**2 * (d1y2 * (x1 - y1) - d1y1 * (x2 - y2)) * HANK1(arg)
          herm1 = herm1 + wgtd * green * 0.25 * (2.0d0 - 3.0d0 * sloc + sloc ** 3.0d0)
          herm2 = herm2 + wgtd * green * 0.25 * (2.0d0 + 3.0d0 * sloc - sloc ** 3.0d0)
          herm3 = herm3 + wgtd * green * 0.25 * ( 1.0d0 - sloc - sloc ** 2.0d0 + sloc ** 3.0d0)
          herm4 = herm4 + wgtd * green * 0.25 * (-1.0d0 - sloc + sloc ** 2.0d0 + sloc ** 3.0d0)

        enddo

      else

        ystart(1) = 1.0d-6
        ystart(2) = 1.0d-6
        ystart(3) = 1.0d-6
        ystart(4) = 1.0d-6
        ystart(5) = 1.0d-6
        ystart(6) = 1.0d-6
        ystart(7) = 1.0d-6
        ystart(8) = 1.0d-6

        call odeint(ystart,nvar,s1,s2,eps,h1,hmin,nok,nbad,CDA0_f,rkqs)

        herm1 = (ystart(1)-1.0d-6) + (0.0d0,1.0d0) * (ystart(2)-1.0d-6)
        herm2 = (ystart(3)-1.0d-6) + (0.0d0,1.0d0) * (ystart(4)-1.0d-6)
        herm3 = (ystart(5)-1.0d-6) + (0.0d0,1.0d0) * (ystart(6)-1.0d-6)
        herm4 = (ystart(7)-1.0d-6) + (0.0d0,1.0d0) * (ystart(8)-1.0d-6)

      endif

!.......................................................................
!               end of subroutine
!.......................................................................
      return
!***********************************************************************
      end

      subroutine CDA0_f(s,y,dydx)
      USE TINoiseGeneric
      USE TINoiseDDD
      USE TINoiseDDD
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: khi,klo

REAL(DbKi)                   :: s,y1,y2,d1y1,d1y2,r2,arg,sloc,greer,greei
REAL(DbKi)                   :: h1,h2,h3,h4

REAL(DbKi)                   :: y(8), dydx(8)

COMPLEX(DbKi)                :: green, HANK1

      call SPL_EX  (sworkat,na+1,s,khi,klo)
      call SPL_EX1 (sworkat,yc1at,d2yc1at,na+1,s,y1,d1y1,khi,klo)
      call SPL_EX1 (sworkat,yc2at,d2yc2at,na+1,s,y2,d1y2,khi,klo)

      r2 = (x1 - y1) ** 2 + (x2 - y2) ** 2
      arg = r2 * kwave2

      sloc = (2.0d0 * s - s1 - s2) / (s2 - s1)
      green = abb1*(d1y2 * (x1 - y1) - d1y1 * (x2 - y2)) * HANK1(arg)

      greer = dble(green)
      greei = dble(-imag*green)

      h1 = 0.25 * (2.0d0 - 3.0d0 * sloc + sloc ** 3.0d0)
      h2 = 0.25 * (2.0d0 + 3.0d0 * sloc - sloc ** 3.0d0)
      h3 = 0.25 * ( 1.0d0 - sloc - sloc ** 2.0d0 + sloc ** 3.0d0)
      h4 = 0.25 * (-1.0d0 - sloc + sloc ** 2.0d0 + sloc ** 3.0d0)

      dydx(1) = h1 * greer
      dydx(2) = h1 * greei
      dydx(3) = h2 * greer
      dydx(4) = h2 * greei
      dydx(5) = h3 * greer
      dydx(6) = h3 * greei
      dydx(7) = h4 * greer
      dydx(8) = h4 * greei

      return
      end


      module MOD_COFREQ
      contains
C**********  MODULNAME: COFREQ    ******* 24/03/87  20.39.20.******    32 KARTEN
      SUBROUTINE COFREQ (XR,XB,XMAX,ERXMIN,GDT,THIN)
      use MOD_FUNSCH
      use MOD_ERF_INF
      use MOD_REGULA
C***  CALCULATES THE CONFINING FREQUENCIES XR AND XB FOR ONE DIRECTION

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

      COMMON / COMFUN / DELTAV,XMIN
      LOGICAL THIN
C***  EPS = ACCURACY DEMAND FOR REGULA
      DATA  EPS / 1.d-3 /

      IF (GDT .GE. 1.d0-2.d0*ERXMIN ) GOTO 3
      THIN=.FALSE.
C***  FOR INNER POINTS :
      ERFXR=GDT+ERXMIN
c      IF (ERFXR.le.0.) then
c         print *,' ERFXR,GDT,ERXMIN: ',ERFXR,GDT,ERXMIN
c         print *,' COFREQ: ERFXR, GDT set to EPS'
c         ERFXR=EPS
c         GDT=EPS
c      endif
      CALL REGULA (ERF_INF   ,XR,ERFXR,-XMAX,XMAX,EPS)
      XB=XMAX

      IF (XR+XMAX .LE. DELTAV) RETURN
C***  BOUNDARY ZONE
         DV2=DELTAV/2.d0
C***     OPTICAL THIN CASE
         IF (GDT .GE. 2.d0*(ERF_INF(DV2)-ERXMIN)-1.d0) GOTO 3
         XMIN=-XMAX
         CALL REGULA (FUNSCH,XR,GDT,XR-EPS,DV2,EPS)
         XB=DELTAV-XR
      RETURN

C***  OPTICAL THIN CASE
    3 THIN=.TRUE.
      XR=.0d0
      XB=.0d0
      RETURN
      end subroutine
      end module


c ------------------------------------------------------------
      subroutine sumax (acc, chi, rx, nx, ncon, ia, na, ad, imax, ngrid,
     &                  nr)
!  routine to perform the summation of contributions from
!  neighbouring atoms (eq. 3.22,3.26,3.28).  integration by
!  trapezium rule on radial grid  rx(i)=exp(-8.8+0.05(i-1))

      dimension acc(ngrid), chi(ngrid,nr), rx(ngrid), nx(nr), ia(ncon)
      dimension na(ncon), ad(ncon)
      double precision sum

      index(x)=20.*(alog(x)+8.8)+2.
      dx=0.05
      ddx=0.5*dx
      dxx=exp(2.*dx)
      ic=ia(1)
      do 10 i = 1, imax
   10   acc(i)=chi(i,ic)
      do 40 ja = 2, ncon
        ic=ia(ja)
        nix=nx(ic)
        do 40 i = 1, imax
        sum=0.0d0
        x1=abs(rx(i)-ad(ja))
        ix1=index(x1)
        if (ix1 .gt. nix) goto 40
        dx1=alog(rx(ix1)/x1)
        rdx1=dx1/dx
        x2=amin1((rx(i)+ad(ja)),rx(nix))
        ix2=min0(index(x2),nix)
        dx2=alog(rx(ix2)/x2)
        rdx2=dx2/dx
        xx=rx(ix2-1)**2
        xx1=xx*dxx
        if (ix1 .eq. ix2) goto 30
        sum=sum+0.5*dx2*((2.-rdx2)*xx*chi(ix2-1,ic)+rdx2*xx1*chi(ix2,ic)
     &   )
        xx=rx(ix1-1)**2
        xx1=xx*dxx
        sum=sum+0.5*dx1*(rdx1*xx*chi(ix1-1,ic)+(2.-rdx1)*xx1*chi(ix1,ic)
     &   )
        ix1=ix1+1
        if (ix1 .eq. ix2) goto 40
        xx=xx1
        t1=ddx*xx*chi(ix1,ic)
        ix2=ix2-1
        do 20 ix = ix1, ix2
          xx=xx*dxx
          t2=ddx*xx*chi(ix,ic)
          sum=sum+t1+t2
   20     t1=t2
        goto 40
   30   sum=0.5*(dx2-dx1)*((rdx1+rdx2)*xx*chi(ix1-1,ic)+(2.-rdx1-rdx2)*
     &   xx1*chi(ix1,ic))
   40   acc(i)=acc(i)+0.5*sum*float(na(ja))/(ad(ja)*rx(i))
      return
      end