!
! Copyright (C) 2001-2007 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------
subroutine dvloc_of_g (mesh, msh, rab, r, vloc_at, zp, tpiba2, ngl, gl, &
     omega, dvloc)
  !----------------------------------------------------------------------
  !
  ! dvloc = D Vloc (g^2) / D g^2 = (1/2g) * D Vloc(g) / D g
  !
  USE kinds
  USE constants , ONLY : pi, fpi, e2, eps8
  implicit none
  !
  !    first the dummy variables
  !
  integer, intent(in) :: ngl, mesh, msh
  ! the number of shell of G vectors
  ! max number of mesh points
  ! number of mesh points for radial integration

  real(DP), intent(in) :: zp, rab (mesh), r (mesh), vloc_at (mesh), &
                          tpiba2, omega, gl (ngl)
  ! valence pseudocharge
  ! the derivative of the radial grid
  ! the radial grid
  ! the pseudo on the radial grid
  ! 2 pi / alat
  ! the volume of the unit cell
  ! the moduli of g vectors for each s
  !
  real(DP), intent(out) ::  dvloc (ngl)
  ! the fourier transform dVloc/dG
  !
  real(DP) :: vlcp, g2a, gx
  real(DP), allocatable ::  aux (:), aux1 (:)
  real(DP), external ::  qe_erf

  integer :: i, igl, igl0
  ! counter on erf functions or gaussians
  ! counter on g shells vectors
  ! first shell with g != 0

  ! the  G=0 component is not computed
  if (gl (1) < eps8) then
     dvloc (1) = 0.0d0
     igl0 = 2
  else
     igl0 = 1
  endif

  ! Pseudopotentials in numerical form (Vloc contains the local part)
  ! In order to perform the Fourier transform, a term erf(r)/r is
  ! subtracted in real space and added again in G space

  allocate (aux( mesh))
  allocate (aux1( mesh))
  !
  !   This is the part of the integrand function
  !   indipendent of |G| in real space
  !
  do i = 1, msh
     aux1 (i) = r (i) * vloc_at (i) + zp * e2 * qe_erf (r (i) )
  enddo
  do igl = igl0, ngl
     gx = sqrt (gl (igl) * tpiba2)
     !
     !    and here we perform the integral, after multiplying for the |G|
     !    dependent  part
     !
     ! DV(g)/Dg = Integral of r (Dj_0(gr)/Dg) V(r) dr
     do i = 1, msh
        aux (i) = aux1 (i) * (r (i) * cos (gx * r (i) ) / gx - sin (gx &
             * r (i) ) / gx**2)
     enddo
     call simpson (msh, aux, rab, vlcp)
     ! DV(g^2)/Dg^2 = (DV(g)/Dg)/2g
     vlcp = fpi / omega / 2.0d0 / gx * vlcp
     ! subtract the long-range term
     g2a = gl (igl) * tpiba2 / 4.d0
     vlcp = vlcp + fpi / omega * zp * e2 * exp ( - g2a) * (g2a + &
          1.d0) / (gl (igl) * tpiba2) **2
     dvloc (igl) = vlcp
  enddo
  deallocate (aux1)
  deallocate (aux)

  return
end subroutine dvloc_of_g
!
!----------------------------------------------------------------------
subroutine dvloc_coul (zp, tpiba2, ngl, gl, omega, dvloc)
  !----------------------------------------------------------------------
  !
  !    Fourier transform of the Coulomb potential - For all-electron
  !    calculations, in specific cases only, for testing purposes
  !
  USE kinds
  USE constants , ONLY : fpi, e2, eps8
  implicit none
  !
  integer, intent(in) :: ngl
  ! the number of shell of G vectors
  real(DP), intent(in) :: zp, tpiba2, omega, gl (ngl)
  ! valence pseudocharge
  ! 2 pi / alat
  ! the volume of the unit cell
  ! the moduli of g vectors for each s
  real(DP), intent(out) :: dvloc (ngl)
  ! fourier transform: dvloc = D Vloc (g^2) / D g^2 = 4pi e^2/omegai /G^4
  !
  integer :: igl0
  ! first shell with g != 0

  ! the  G=0 component is 0
  if (gl (1) < eps8) then
     dvloc (1) = 0.0d0
     igl0 = 2
  else
     igl0 = 1
  endif

  dvloc  (igl0:ngl) = fpi * zp * e2 / omega / ( tpiba2 * gl (igl0:ngl) ) ** 2

return
end subroutine dvloc_coul


      SUBROUTINE CONGRAD (ISTL_)
C
C CHANGE RECORD
C **  SUBROUTINE CONGRAD SOLVES THE EXTERNAL MODE BY A CONJUGATE
C **  GRADIENT SCHEME
C
      USE GLOBAL
      USE OMP_LIB
      DOUBLE PRECISION LST,LEND,foo
      REAL(KIND=8) PAPCG,RPCG

      ! *** DSLLC
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PNORTH
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PSOUTH
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TMPCG
      IF(.NOT.ALLOCATED(PNORTH))THEN
		ALLOCATE(PNORTH(LCM))
		ALLOCATE(PSOUTH(LCM))
		ALLOCATE(TMPCG(LCM))
	    PNORTH=0.0
		PSOUTH=0.0
		TMPCG=0.0
	ENDIF
      ! *** DSLLC
C
      TTMP=SECNDS(SECNDS_ZERO)
      DO L=2,LA
        LN=LNC(L)
        LS=LSC(L)
        PNORTH(L)=P(LN)
        PSOUTH(L)=P(LS)
      ENDDO
      DO L=2,LA
        LE=LEAST(L)
        RCG(L)=FPTMP(L)-CCC(L)*P(L)-CCN(L)*PNORTH(L)-CCS(L)*PSOUTH(L)
     &      -CCW(L)*P(LWEST(L))-CCE(L)*P(LE)
      ENDDO
      DO L=2,LA
        PCG(L)=RCG(L)*CCCI(L)
      ENDDO
      RPCG=0.
      DO L=2,LA
        RPCG=RPCG+RCG(L)*PCG(L)
      ENDDO
      IF(RPCG.EQ.0.0)RETURN   ! *** DSLLC SINGLE LINE
      ITER=0
  100 CONTINUE
      ITER=ITER+1
      DO L=2,LA
        LN=LNC(L)
        LS=LSC(L)
        PNORTH(L)=PCG(LN)
        PSOUTH(L)=PCG(LS)
      ENDDO
      DO L=2,LA
        LE=LEAST(L)
        APCG(L)=CCC(L)*PCG(L)+CCS(L)*PSOUTH(L)+CCN(L)*PNORTH(L)
     &      +CCW(L)*PCG(LWEST(L))+CCE(L)*PCG(LE)
      ENDDO
      PAPCG=0.
      DO L=2,LA
        PAPCG=PAPCG+APCG(L)*PCG(L)
      ENDDO
      ALPHA=RPCG/PAPCG
      DO L=2,LA
        P(L)=P(L)+ALPHA*PCG(L)
      ENDDO
      DO L=2,LA
        RCG(L)=RCG(L)-ALPHA*APCG(L)
      ENDDO
      DO L=2,LA
        TMPCG(L)=CCCI(L)*RCG(L)
      ENDDO
      RPCGN=0.
      RSQ=0.
      DO L=2,LA
        RPCGN=RPCGN+RCG(L)*TMPCG(L)
        RSQ=RSQ+RCG(L)*RCG(L)
      ENDDO

      IF(RSQ .LE. RSQM) GOTO 200
      IF(ITER .GE. ITERM)THEN
        WRITE(6,600)
C
C *** PMC BEGIN BLOCK
C
      WRITE(8,*)'  I    J       CCS          CCW          CCC
     &    CCE          CCN        CDIADOM       FPTMP         HU
     &    HV'

      CALL SURFPLT
      CALL VELPLTH
      CALL EEXPOUT(-1)
C
C *** PMC END BLOCK
C
        DO L=1,LC
          CDIADOM=CCC(L)+CCE(L)+CCN(L)+CCS(L)+CCW(L)
          WRITE(8,808)IL(L),JL(L),CCS(L),CCW(L),CCC(L),CCE(L),CCN(L),
     &        CDIADOM,FPTMP(L),HU(L),HV(L)
        END DO
        CLOSE(8)
        STOP
      ENDIF
      BETA=RPCGN/RPCG
      RPCG=RPCGN
      DO L=2,LA
        PCG(L)=TMPCG(L)+BETA*PCG(L)
      ENDDO
      GOTO 100
  600 FORMAT('  MAXIMUM ITERATIONS EXCEEDED IN EXTERNAL SOLUTION')
C
C ** CALCULATE FINAL RESIDUAL
C
  200 CONTINUE
      ! *** DSLLC BEGIN BLOCK
      IF(ISLOG.GE.1)THEN
        DO L=2,LA
          LN=LNC(L)
          LS=LSC(L)
          PNORTH(L)=P(LN)
          PSOUTH(L)=P(LS)
        ENDDO
        RSQ=0.
        DO L=2,LA
          LE=LEAST(L)
          LW=LWEST(L)
          RCG(L)=CCC(L)*P(L)+CCS(L)*PSOUTH(L)+CCN(L)*PNORTH(L)
     &      +CCW(L)*P(LW)+CCE(L)*P(LE)-FPTMP(L)
        ENDDO
        DO L=2,LA
          RCG(L)=RCG(L)*CCCI(L)
        ENDDO
        DO L=2,LA
          RSQ=RSQ+RCG(L)*RCG(L)
        ENDDO
      ENDIF
      ! *** DSLLC END BLOCK
      TCONG=TCONG+SECNDS(TTMP)
  800 FORMAT(I5,8E13.4)
  808 FORMAT(2I5,9E13.4)
      RETURN
      END


!-----------------------------------------------------------------------------
        subroutine gengrid
!
!  Generate the grid
!
!-----------------------------------------------------------------------------
        use global
        implicit none

        integer :: i, j, k, ier, mem = 0, ij
        real    :: tmp
        character*80 name
!-----------------------------------------------------------------------------

!.... read in the grid

        name = 'grid.dat'
        open (unit=10, file=name, form='unformatted', &
              status='old', err=1000)
        read(10,err=1000,end=1000) nx, ny, nz
        write(*,"(' Reading grid for (',i4,',',i4,',',i4,')')") nx, ny, nz

!.... check to make sure that Ny is not a power of two for implicit

        mem = mem + ny*nx*2 + nz + nx + ny
        allocate (x(ny,nx), y(ny,nx), z(nz), xi(nx), eta(ny), STAT=ier)
        if (ier .ne. 0) call error('gengrid$','Insufficient Memory for grid$')
        read(10,err=1000,end=1000) &
                 (((x(j,i), i = 1, nx), j = 1, ny), k = 1, nz), &
                 (((y(j,i), i = 1, nx), j = 1, ny), k = 1, nz), &
                 (((   tmp, i = 1, nx), j = 1, ny), k = 1, nz)
        close(10)

!.... make the xi grid

        dxi = one / float(nx-1)

        do i = 1, nx
          xi(i) = zero + (i-1) * dxi
        end do

!.... make the eta grid

        deta = one / float(ny-1)

        do j = 1, ny
          eta(j) = float(j-1) * deta
        end do

!.... make z grid

        z = zero

!.... allocate storage for metrics

        mem = mem + ny*nx*10
        allocate (m1(ny*nx),  m2(ny*nx),  n1(ny*nx),  n2(ny*nx), &
                  m11(ny*nx), m12(ny*nx), m22(ny*nx),            &
                  n11(ny*nx), n12(ny*nx), n22(ny*nx), STAT=ier)
        if (ier .ne. 0) call error('gengrid$', &
                        'Insufficient Memory for mesh metrics$')

!.... read in the mesh metrics

        open (unit=10,file='metric.dat',form='unformatted', &
              status='old', err=1100)
        read(10,err=1100,end=1000) &
              m1, m2, n1, n2, m11, m12, m22, n11, n12, n22
        close(10)

!.... form the metric products

        mem = mem + ny*nx*3
        allocate (m1m1(ny*nx), m1m2(ny*nx), m2m2(ny*nx), STAT=ier)
        if (ier .ne. 0) call error('gengrid$','Insufficient Memory$')

        m1m1 = m1 * m1
        m1m2 = m1 * m2
        m2m2 = m2 * m2

        mem = mem + ny*nx*3
        allocate (n1n1(ny*nx), n1n2(ny*nx), n2n2(ny*nx), STAT=ier)
        if (ier .ne. 0) call error('gengrid$','Insufficient Memory$')

        n1n1 = n1 * n1
        n1n2 = n1 * n2
        n2n2 = n2 * n2

        mem = mem + ny*nx*3
        allocate (m1n1(ny*nx), m1n2(ny*nx), m2n1(ny*nx), m2n2(ny*nx), STAT=ier)
        if (ier .ne. 0) call error('gengrid$','Insufficient Memory$')

        m1n1 = m1 * n1
        m1n2 = m1 * n2
        m2n1 = m2 * n1
        m2n2 = m2 * n2

!.... compute the boundary normal vectors.  These are defined such that
!.... they allways point outside of the domain.

        allocate( bnl(ny,2), bnr(ny,2), bnb(nx,2), bnt(nx,2), STAT=ier )
        if (ier .ne. 0) call error('gengrid$','Insufficient Memory$')

        j = 1
        do i = 1, nx
          ij = j + (i-1) * ny
          bnb(i,1) = -n1(ij) / sqrt( n1(ij)**2 + n2(ij)**2 )
          bnb(i,2) = -n2(ij) / sqrt( n1(ij)**2 + n2(ij)**2 )
        end do

        j = ny
        do i = 1, nx
          ij = j + (i-1) * ny
          bnt(i,1) = n1(ij) / sqrt( n1(ij)**2 + n2(ij)**2 )
          bnt(i,2) = n2(ij) / sqrt( n1(ij)**2 + n2(ij)**2 )
        end do

        i = 1
        do j = 1, ny
          ij = j + (i-1) * ny
          bnl(j,1) = -m1(ij) / sqrt( m1(ij)**2 + m2(ij)**2 )
          bnl(j,2) = -m2(ij) / sqrt( m1(ij)**2 + m2(ij)**2 )
        end do

        i = nx
        do j = 1, ny
          ij = j + (i-1) * ny
          bnr(j,1) = m1(ij) / sqrt( m1(ij)**2 + m2(ij)**2 )
          bnr(j,2) = m2(ij) / sqrt( m1(ij)**2 + m2(ij)**2 )
        end do

        write(*,"(' GenGrid allocated ===> ',1pe13.6,' words')") float(mem)

        return
1000    call error('gengrid$','Error reading grid$')
1100    call error('gengrid$','Error reading metrics$')
        end


      SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
     $                   IDXQ, IWORK, WORK, INFO )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDU, LDVT, NL, NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            IDXQ( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
*  where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.
*
*  A related subroutine DLASD7 handles the case in which the singular
*  values (and the singular vectors in factored form) are desired.
*
*  DLASD1 computes the SVD as follows:
*
*                ( D1(in)  0    0     0 )
*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)
*                (   0     0   D2(in) 0 )
*
*      = U(out) * ( D(out) 0) * VT(out)
*
*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
*  elsewhere; and the entry b is empty if SQRE = 0.
*
*  The left singular vectors of the original matrix are stored in U, and
*  the transpose of the right singular vectors are stored in VT, and the
*  singular values are in D.  The algorithm consists of three stages:
*
*     The first stage consists of deflating the size of the problem
*     when there are multiple singular values or when there are zeros in
*     the Z vector.  For each such occurence the dimension of the
*     secular equation problem is reduced by one.  This stage is
*     performed by the routine DLASD2.
*
*     The second stage consists of calculating the updated
*     singular values. This is done by finding the square roots of the
*     roots of the secular equation via the routine DLASD4 (as called
*     by DLASD3). This routine also calculates the singular vectors of
*     the current problem.
*
*     The final stage consists of computing the updated singular vectors
*     directly using the updated singular values.  The singular vectors
*     for the current problem are multiplied with the singular vectors
*     from the overall problem.
*
*  Arguments
*  =========
*
*  NL     (input) INTEGER
*         The row dimension of the upper block.  NL >= 1.
*
*  NR     (input) INTEGER
*         The row dimension of the lower block.  NR >= 1.
*
*  SQRE   (input) INTEGER
*         = 0: the lower block is an NR-by-NR square matrix.
*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
*         The bidiagonal matrix has row dimension N = NL + NR + 1,
*         and column dimension M = N + SQRE.
*
*  D      (input/output) DOUBLE PRECISION array,
*                        dimension (N = NL+NR+1).
*         On entry D(1:NL,1:NL) contains the singular values of the
*         upper block; and D(NL+2:N) contains the singular values of
*         the lower block. On exit D(1:N) contains the singular values
*         of the modified matrix.
*
*  ALPHA  (input/output) DOUBLE PRECISION
*         Contains the diagonal element associated with the added row.
*
*  BETA   (input/output) DOUBLE PRECISION
*         Contains the off-diagonal element associated with the added
*         row.
*
*  U      (input/output) DOUBLE PRECISION array, dimension(LDU,N)
*         On entry U(1:NL, 1:NL) contains the left singular vectors of
*         the upper block; U(NL+2:N, NL+2:N) contains the left singular
*         vectors of the lower block. On exit U contains the left
*         singular vectors of the bidiagonal matrix.
*
*  LDU    (input) INTEGER
*         The leading dimension of the array U.  LDU >= max( 1, N ).
*
*  VT     (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
*         where M = N + SQRE.
*         On entry VT(1:NL+1, 1:NL+1)' contains the right singular
*         vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
*         the right singular vectors of the lower block. On exit
*         VT' contains the right singular vectors of the
*         bidiagonal matrix.
*
*  LDVT   (input) INTEGER
*         The leading dimension of the array VT.  LDVT >= max( 1, M ).
*
*  IDXQ  (output) INTEGER array, dimension(N)
*         This contains the permutation which will reintegrate the
*         subproblem just solved back into sorted order, i.e.
*         D( IDXQ( I = 1, N ) ) will be in ascending order.
*
*  IWORK  (workspace) INTEGER array, dimension( 4 * N )
*
*  WORK   (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )
*
*  INFO   (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*          > 0:  if INFO = 1, an singular value did not converge
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Ming Gu and Huan Ren, Computer Science Division, University of
*     California at Berkeley, USA
*
*  =====================================================================
*
*     .. Parameters ..
*
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
     $                   IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
      DOUBLE PRECISION   ORGNRM
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IF( NL.LT.1 ) THEN
         INFO = -1
      ELSE IF( NR.LT.1 ) THEN
         INFO = -2
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD1', -INFO )
         RETURN
      END IF
*
      N = NL + NR + 1
      M = N + SQRE
*
*     The following values are for bookkeeping purposes only.  They are
*     integer pointers which indicate the portion of the workspace
*     used by a particular array in DLASD2 and DLASD3.
*
      LDU2 = N
      LDVT2 = M
*
      IZ = 1
      ISIGMA = IZ + M
      IU2 = ISIGMA + N
      IVT2 = IU2 + LDU2*N
      IQ = IVT2 + LDVT2*M
*
      IDX = 1
      IDXC = IDX + N
      COLTYP = IDXC + N
      IDXP = COLTYP + N
*
*     Scale.
*
      ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
      D( NL+1 ) = ZERO
      DO 10 I = 1, N
         IF( ABS( D( I ) ).GT.ORGNRM ) THEN
            ORGNRM = ABS( D( I ) )
         END IF
   10 CONTINUE
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
      ALPHA = ALPHA / ORGNRM
      BETA = BETA / ORGNRM
*
*     Deflate singular values.
*
      CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
     $             VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
     $             WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
     $             IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
*
*     Solve Secular Equation and update singular vectors.
*
      LDQ = K
      CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
     $             U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
     $             LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
     $             INFO )
      IF( INFO.NE.0 ) THEN
         RETURN
      END IF
*
*     Unscale.
*
      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
*     Prepare the IDXQ sorting permutation.
*
      N1 = K
      N2 = N - K
      CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
*
      RETURN
*
*     End of DLASD1
*
      END


SUBROUTINE p811(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.11 Plane or axisymmetric thermal conduction analysis using
!         4-node rectangular quadrilaterals. Option of convection and
!         flux boundary conditions.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,j,k,nci,ncon,ndim=2,nels,neq,nflx,nip=4,   &
   nlen,nn,nod=4,nodl=2,npri,nprops=3,np_types,nres,nstep,ntime,nxe,nye
 REAL(iwp)::det,dtim,d3=3.0_iwp,d4=4.0_iwp,d6=6.0_iwp,d12=12.0_iwp,       &
   hpl,one=1.0_iwp,length,penalty=1.0e20_iwp,pt5=0.5_iwp,theta,time,      &
   two=2.0_iwp,zero=0.0_iwp
 CHARACTER(len=15)::argv,dir,element='quadrilateral',type_2d
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::econn(:,:),etype(:),g_num(:,:),node(:),num(:),kdiag(:)
 REAL(iwp),ALLOCATABLE::bp(:),coord(:,:),der(:,:),deriv(:,:),econv(:,:),  &
   flxv(:),fun(:),gc(:),g_coord(:,:),jac(:,:),kay(:,:),kc(:,:),kcl(:,:),  &
   kv(:),loads(:),newlo(:),ntn(:,:),mm(:,:),points(:,:),prop(:,:),rhs(:), &
   storbp(:),value(:),weights(:),x_coords(:),y_coords(:)
!-------------------------input and initialisation------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)type_2d,dir,nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 neq=nn
 ALLOCATE(points(nip,ndim),weights(nip),kay(ndim,ndim),coord(nod,ndim),   &
   fun(nod),jac(ndim,ndim),g_coord(ndim,nn),der(ndim,nod),deriv(ndim,nod),&
   mm(nod,nod),g_num(nod,nels),kc(nod,nod),ntn(nod,nod),num(nod),         &
   etype(nels),kdiag(neq),loads(0:neq),newlo(0:neq),flxv(0:neq),          &
   x_coords(nxe+1),y_coords(nye+1),prop(nprops,np_types),gc(ndim),        &
   kcl(nodl,nodl),rhs(0:neq))
 READ(10,*)prop
 etype=1
 if(np_types>1)read(10,*)etype
 READ(10,*)x_coords,y_coords
 READ(10,*)dtim,nstep,theta,npri,nres,ntime
 kdiag=0
! ----------loop the elements to set up global geometry and kdiag --------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,dir)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   CALL fkdiag(kdiag,num)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),bp(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 CALL sample(element,points,weights)
 bp=zero
 kv=zero
 gc=one
!-----------------------global conductivity and "mass" matrix assembly----
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   kc=zero
   mm=zero
   gauss_pts: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     if(type_2d=='axisymmetric')gc=MATMUL(fun,coord)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)*gc(1)
     CALL cross_product(fun,fun,ntn)
     mm=mm+ntn*det*weights(i)*gc(1)*prop(3,etype(iel))
   END DO gauss_pts
   CALL fsparv(kv,kc,num,kdiag)
   CALL fsparv(bp,mm,num,kdiag)
 END DO elements_2
 flxv=zero
 READ(10,*)nflx,(k,flxv(k),i=1,nflx);rhs=flxv
 READ(10,*)ncon
 IF(ncon/=0)THEN
   ALLOCATE(econn(nodl,ncon),econv(2,ncon))
   READ(10,*)(econn(:,i),econv(:,i),i=1,ncon)
   DO i=1,ncon
     length=SQRT((g_coord(1,econn(1,i))-g_coord(1,econn(2,i)))**2         &
                +(g_coord(2,econn(1,i))-g_coord(2,econn(2,i)))**2)
     hpl=econv(1,i)*length
     IF(type_2d=='axisymmetric')THEN
       rhs(econn(1,i))=rhs(econn(1,i))+hpl*econv(2,i)*                    &
	      (two*g_coord(1,econn(1,i))+g_coord(1,econn(2,i)))/d6
       rhs(econn(2,i))=rhs(econn(2,i))+hpl*econv(2,i)*                    &
	      (two*g_coord(1,econn(2,i))+g_coord(1,econn(1,i)))/d6
       kcl(1,1)=hpl*(g_coord(1,econn(1,i))/d4+g_coord(1,econn(2,i))/d12)
       kcl(1,2)=hpl*(g_coord(1,econn(1,i))+g_coord(1,econn(2,i)))/d12
       kcl(2,2)=hpl*(g_coord(1,econn(2,i))/d4+g_coord(1,econn(1,i))/d12)
       kcl(2,1)=kcl(1,2)
     ELSE
       rhs(econn(:,i))=rhs(econn(:,i))+hpl*econv(2,i)*pt5
       kcl(1,1)=hpl/d3
       kcl(1,2)=hpl/d6
       kcl(2,1)=kcl(1,2)
       kcl(2,2)=kcl(1,1)
	 ENDIF
     CALL fsparv(kv,kcl,econn(:,i),kdiag)
   END DO
 END IF
 kv=kv*theta*dtim
 bp=bp+kv
 kv=bp-kv/theta
 rhs=rhs*dtim
!-----------------------specify initial and boundary values---------------
 READ(10,*)loads(1:)
 loads(0)=zero
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)then
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms),                   &
            storbp(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   bp(kdiag(node))=bp(kdiag(node))+penalty
   storbp=bp(kdiag(node))
 END IF
!-----------------------factorise equations-------------------------------
 CALL sparin(bp,kdiag)
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/A,I3,A)')"    Time      Pressure (node",nres,")"
 WRITE(11,'(2E12.4)')0.0,loads(nres)
 timesteps: DO j=1,nstep
   time=j*dtim
   CALL linmul_sky(kv,loads,newlo,kdiag)
   newlo=newlo+rhs
   IF(fixed_freedoms/=0)newlo(node)=storbp*value
   CALL spabac(bp,newlo,kdiag)
   loads=newlo
   IF(nod==4.AND.j==ntime)THEN
     READ(10,*)nci
     CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)
   END IF
   IF(j/npri*npri==j)WRITE(11,'(2E12.4)')time,loads(nres)
 END DO timesteps

END SUBROUTINE p811


!
!   updateforecast.f90
!
!
!   Created by Kurt Mitman on 24/01/15.
!   Copyright 2015 __MyCompanyName__. All rights reserved.
!
subroutine updateforecast

    use params
    use globals
    use funcs
    use procedures
    implicit none

    integer::counts(ngpAgg*ngpAgg)
    integer::kcounts(ngpAgg)
    integer::zindex,t,n_ols,k_ols,iAgg,iAggp
    double precision::R2
    double precision::meany
    double precision,allocatable::xt(:,:)
    double precision,allocatable::beta_ols(:),yyt(:),resid(:)

    double precision,dimension(Tsim-1)::Phvec,Phvecp

    n_ols=Tsim-101
    k_ols=ngpAgg*ngpAgg+ngpAgg
    allocate(Xt(n_ols,k_ols))
    allocate(yyt(n_ols))
    allocate(resid(n_ols))
    yyt=0.0d0
    Xt=0.0d0

    do t=100,Tsim-2
        iAgg=iAggpath(t)
        iAggp=iAggpath(t+1)
        zindex=(iAgg-1)*ngpAgg+iAggp
        Xt(t-99,zindex)=1.0d0
        Xt(t-99,ngpAgg*ngpAgg+iAgg)=log(Phpath(t))
        yyt(t-99)=log(Phpath(t+1))

    enddo

    aa0p=0.0d0
    aa1p=0.0d0

    allocate(beta_ols(k_ols))
    beta_ols=0.0d0
    call OLS(n_ols,k_ols,Xt,yyt,beta_ols)

    do iAgg=1,ngpAgg
       aa1p(iAgg,:)=beta_ols(ngpAgg*ngpAgg+iAgg)
       do iAggp=1,ngpAgg
            aa0p(iAgg,iAggp)=beta_ols((iAgg-1)*ngpAgg+iAggp)
        enddo

    enddo
    resid=yyt-matmul(Xt,beta_ols)
    meany=sum(yyt(1:n_ols))/real(n_ols)
    R2=1.0d0-sum( resid**2.0d0 )/sum( (yyt-meany)**2.0d0)
    print*,'R2= ',R2

end subroutine updateforecast


!use SoilClass
use BoringClass
use SoilClass
implicit none

!type(Soil_) :: soil
integer(int32) ,parameter :: num_boring_x_y=10
type(Boring_) :: boring(num_boring_x_y*num_boring_x_y)
type(Soil_) :: soil
type(IO_) :: f
type(Random_) :: random
real(real64),allocatable :: Nvalue(:),Vs(:)
integer(int32) :: id

do i_i = 1,num_boring_x_y
    do j_j=1,num_boring_x_y
        id = (i_i-1)*num_boring_x_y + j_j
        call boring(id)%example()
        boring(id)%x = 100.0d0/dble(num_boring_x_y)* dble(i_i)! + random%gauss(mu=0.0d0,sigma=5.0d0)
        boring(id)%y = 100.0d0/dble(num_boring_x_y)* dble(j_j)! + random%gauss(mu=0.0d0,sigma=5.0d0)
        boring(id)%PTest_NValue = boring(id)%PTest_NValue
        boring(id)%PTest_Depth  = boring(id)%PTest_Depth &
        + ((boring(id)%x)**2+(boring(id)%y)**2)/1000.0d0
    enddo
enddo

! create ground
call soil%init(x_num=100,y_num=100,z_num=10)
call soil%resize(x=100.0d0)
call soil%resize(y=100.0d0)
call soil%resize(z=20.0d0)
call soil%move(x=50.0d0)
call soil%move(y=50.0d0)
!call soil%move(z=-15.0d0)

!stop
print *, boring(1)%url
Nvalue = soil%getNvalue(borings=boring)
Vs     = soil%convertNvalue2Vs(Nvalue=Nvalue,Formula=PF_N2Vs_JAPANROAD_1)
call soil%femdomain%vtk("soil",scalar=Vs)

call f%open("Vs.txt")
call f%write(Vs)
call f%close()

end


      SUBROUTINE DL7NVR(N, LIN, L)
C
C  ***  COMPUTE  LIN = L**-1,  BOTH  N X N  LOWER TRIANG. STORED   ***
C  ***  COMPACTLY BY ROWS.  LIN AND L MAY SHARE THE SAME STORAGE.  ***
C
C  ***  PARAMETERS  ***
C
      INTEGER N
      DOUBLE PRECISION L(1), LIN(1)
C     DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1
      DOUBLE PRECISION ONE, T, ZERO
C/6
C     DATA ONE/1.D+0/, ZERO/0.D+0/
C/7
      PARAMETER (ONE=1.D+0, ZERO=0.D+0)
C/
C
C  ***  BODY  ***
C
      NP1 = N + 1
      J0 = N*(NP1)/2
      DO 30 II = 1, N
         I = NP1 - II
         LIN(J0) = ONE/L(J0)
         IF (I .LE. 1) GO TO 999
         J1 = J0
         IM1 = I - 1
         DO 20 JJ = 1, IM1
              T = ZERO
              J0 = J1
              K0 = J1 - JJ
              DO 10 K = 1, JJ
                   T = T - L(K0)*LIN(J0)
                   J0 = J0 - 1
                   K0 = K0 + K - I
 10                CONTINUE
              LIN(J0) = T/L(K0)
 20           CONTINUE
         J0 = J0 - 1
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF DL7NVR FOLLOWS  ***
      END


*DECK BSQAD
      SUBROUTINE BSQAD (T, BCOEF, N, K, X1, X2, BQUAD, WORK)
C***BEGIN PROLOGUE  BSQAD
C***PURPOSE  Compute the integral of a K-th order B-spline using the
C            B-representation.
C***LIBRARY   SLATEC
C***CATEGORY  H2A2A1, E3, K6
C***TYPE      SINGLE PRECISION (BSQAD-S, DBSQAD-D)
C***KEYWORDS  INTEGRAL OF B-SPLINES, QUADRATURE
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BSQAD computes the integral on (X1,X2) of a K-th order
C         B-spline using the B-representation (T,BCOEF,N,K).  Orders
C         K as high as 20 are permitted by applying a 2, 6, or 10
C         point Gauss formula on subintervals of (X1,X2) which are
C         formed by included (distinct) knots.
C
C         If orders K greater than 20 are needed, use BFQAD with
C         F(X) = 1.
C
C     Description of Arguments
C         Input
C           T      - knot array of length N+K
C           BCOEF  - B-spline coefficient array of length N
C           N      - length of coefficient array
C           K      - order of B-spline, 1 .LE. K .LE. 20
C           X1,X2  - end points of quadrature interval in
C                    T(K) .LE. X .LE. T(N+1)
C
C         Output
C           BQUAD  - integral of the B-spline over (X1,X2)
C           WORK   - work vector of length 3*K
C
C     Error Conditions
C         Improper input is a fatal error
C
C***REFERENCES  D. E. Amos, Quadrature subroutines for splines and
C                 B-splines, Report SAND79-1825, Sandia Laboratories,
C                 December 1979.
C***ROUTINES CALLED  BVALU, INTRV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BSQAD
C
      INTEGER I,IL1,IL2,ILO,INBV, JF,K,LEFT,M,MF,MFLAG,N, NPK, NP1
      REAL A, AA, B, BB, BCOEF, BMA, BPA, BQUAD, C1, GPTS, GWTS, GX, Q,
     1 SUM, T, TA, TB, WORK, X1, X2, Y1, Y2
      REAL BVALU
      DIMENSION T(*), BCOEF(*), GPTS(9), GWTS(9), SUM(5), WORK(*)
C
      SAVE GPTS, GWTS
      DATA GPTS(1), GPTS(2), GPTS(3), GPTS(4), GPTS(5), GPTS(6),
     1     GPTS(7), GPTS(8), GPTS(9)/
     2     5.77350269189625764E-01,     2.38619186083196909E-01,
     3     6.61209386466264514E-01,     9.32469514203152028E-01,
     4     1.48874338981631211E-01,     4.33395394129247191E-01,
     5     6.79409568299024406E-01,     8.65063366688984511E-01,
     6     9.73906528517171720E-01/
      DATA GWTS(1), GWTS(2), GWTS(3), GWTS(4), GWTS(5), GWTS(6),
     1     GWTS(7), GWTS(8), GWTS(9)/
     2     1.00000000000000000E+00,     4.67913934572691047E-01,
     3     3.60761573048138608E-01,     1.71324492379170345E-01,
     4     2.95524224714752870E-01,     2.69266719309996355E-01,
     5     2.19086362515982044E-01,     1.49451349150580593E-01,
     6     6.66713443086881376E-02/
C
C***FIRST EXECUTABLE STATEMENT  BSQAD
      BQUAD = 0.0E0
      IF(K.LT.1 .OR. K.GT.20) GO TO 65
      IF(N.LT.K) GO TO 70
      AA = MIN(X1,X2)
      BB = MAX(X1,X2)
      IF (AA.LT.T(K)) GO TO 60
      NP1 = N + 1
      IF (BB.GT.T(NP1)) GO TO 60
      IF (AA.EQ.BB) RETURN
      NPK = N + K
C     SELECTION OF 2, 6, OR 10 POINT GAUSS FORMULA
      JF = 0
      MF = 1
      IF (K.LE.4) GO TO 10
      JF = 1
      MF = 3
      IF (K.LE.12) GO TO 10
      JF = 4
      MF = 5
   10 CONTINUE
C
      DO 20 I=1,MF
        SUM(I) = 0.0E0
   20 CONTINUE
      ILO = 1
      INBV = 1
      CALL INTRV(T, NPK, AA, ILO, IL1, MFLAG)
      CALL INTRV(T, NPK, BB, ILO, IL2, MFLAG)
      IF (IL2.GE.NP1) IL2 = N
      DO 40 LEFT=IL1,IL2
        TA = T(LEFT)
        TB = T(LEFT+1)
        IF (TA.EQ.TB) GO TO 40
        A = MAX(AA,TA)
        B = MIN(BB,TB)
        BMA = 0.5E0*(B-A)
        BPA = 0.5E0*(B+A)
        DO 30 M=1,MF
          C1 = BMA*GPTS(JF+M)
          GX = -C1 + BPA
          Y2 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK)
          GX = C1 + BPA
          Y1 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK)
          SUM(M) = SUM(M) + (Y1+Y2)*BMA
   30   CONTINUE
   40 CONTINUE
      Q = 0.0E0
      DO 50 M=1,MF
        Q = Q + GWTS(JF+M)*SUM(M)
   50 CONTINUE
      IF (X1.GT.X2) Q = -Q
      BQUAD = Q
      RETURN
C
C
   60 CONTINUE
      CALL XERMSG ('SLATEC', 'BSQAD',
     +   'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1)
      RETURN
   65 CONTINUE
      CALL XERMSG ('SLATEC', 'BSQAD', 'K DOES NOT SATISFY 1.LE.K.LE.20'
     +   , 2, 1)
      RETURN
   70 CONTINUE
      CALL XERMSG ('SLATEC', 'BSQAD', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
      END


program geometry
implicit none

!===============================================================================
!
!  this script calculates the geometrical fields used in the calculation of the
!  Lorenz Energy Cycle in the high resolution POP model (0.1 deg)
! DXT, DXU
! DYT, DYU
! DZT, DZU
! TAREA, UAREA
!
!===============================================================================

!===============================================================================
!  variables
!===============================================================================

character*120 :: &
  LEC_folder,grid_file,kmt_file,in_depths,pbc_file,geometry1_file,geometry2_file

integer :: imt,jmt,km,rec_length,i,j,k
integer, dimension(:,:), allocatable :: kmT

double precision :: volume
double precision, dimension(:),   allocatable :: z1, z2,tdz
double precision, dimension(:,:), allocatable ::                            &
HTN, HTE, WORK, DXT, DYT, TAREA, DXU, DYU, UAREA, DZBC, HUW, HUS, WORK2,    &
WORK3
double precision, parameter ::                                              &
c0 = 0., p125 = 0.125, p25 = 0.25, p5 = 0.5, c1 = 1.

real, dimension(:),     allocatable :: area,dz,tdepth,p_z,vol
real, dimension(:,:,:), allocatable :: DZT, DZU

imt            = 3600
jmt            = 2400
km             =   42

LEC_folder     = '/home/dijkbio/andre/LEC/'
grid_file      = trim(LEC_folder)//'input/grid.3600x2400.fob.da'
kmt_file       = trim(LEC_folder)//'input/kmt_pbc.p1_tripole.s2.0-og.20060315.no_caspian_or_black'
in_depths      = trim(LEC_folder)//'input/in_depths.42.dat'
pbc_file       = trim(LEC_folder)//'input/dzbc_pbc.p1_tripole.s2.0-og.20060315.no_caspian_or_black'

geometry1_file = trim(LEC_folder)//'input/geometry1'
geometry2_file = trim(LEC_folder)//'input/geometry2'

write (*,*) ''
write (*,*) '--- GEOMETRY ---'
write (*,*) ''

!===============================================================================
!  read and create horizontal grid spacing, define TAREA
!===============================================================================

allocate(                                                                      &
  HTN(imt,jmt), HTE(imt,jmt), HUW(imt,jmt), HUS(imt,jmt), WORK(imt,jmt),       &
  WORK2(imt,jmt), WORK3(imt,jmt), DXT(imt,jmt), DYT(imt,jmt), TAREA(imt,jmt),  &
  DXU(imt,jmt), DYU(imt,jmt), UAREA(imt,jmt) )

inquire (iolength = rec_length) HTN
!write   (*,*) 'HTN  rec_length', rec_length, imt,jmt
open    (1,file=grid_file,access='direct',form='unformatted',recl=rec_length,  &
           status='unknown')
  read  (1,rec=3) HTN ! [cm]
  read  (1,rec=4) HTE ! [cm]
close   (1)

where (HTN <= c0) HTN = c1
where (HTE <= c0) HTE = c1

call s_rshift(WORK,HTN,imt,jmt)
DXT   = p5*(HTN + WORK)
call w_rshift(WORK,HTE,imt,jmt)
DYT   = p5*(HTE + WORK)
TAREA = DXT*DYT ! [cm^2]

call e_rshift(WORK,HTN,imt,jmt)
DXU   = p5*(HTN + WORK)
call n_rshift(WORK,HTE,imt,jmt)
DYU   = p5*(HTE + WORK)
UAREA = DXU*DYU

! create HUW and HUS (as straight averages of surrrounding HTE/HTN according
! to Reference Manual)
call n_rshift(WORK,HTE,imt,jmt)
call w_rshift(WORK2,WORK,imt,jmt)
call w_rshift(WORK3,HTE,imt,jmt)
HUW   = p5*p5 * ( HTE + WORK + WORK2 + WORK3 ) ! [cm]
call s_rshift(WORK,HTN,imt,jmt)
call e_rshift(WORK2,WORK,imt,jmt)
call e_rshift(WORK3,HTN,imt,jmt)
HUS   = p5*p5 * ( HTN + WORK + WORK2 + WORK3 ) ! [cm]

!   deallocate( WORK, WORK2, WORK3 )

!===============================================================================
!  read bathymetry and depth level variables, define DZT and DZU
!===============================================================================

allocate( dz(km), kmT(imt,jmt), DZBC(imt,jmt), DZT(imt,jmt,km), DZU(imt,jmt,km),&
          tdz(km), tdepth(km), area(km), p_z(km), vol(km) )

! kmT
inquire (iolength=rec_length) kmT
!write   (*,*) 'kmT  rec_length', rec_length, imt,jmt
open    (1,file=kmt_file,access='direct',form='unformatted',recl=rec_length,   &
           status='unknown')
  read  (1,rec=1) kmT
close   (1)
!write   (*,*) 'kmT file: ', kmt_file

! dz
open     (1,file=in_depths,status='old')
  do k = 1, km
    read (1,*) dz(k) ! [cm]
  enddo  !k
close    (1)
!write   (*,*) 'dz(k) file: ', in_depths

! partial bottom cell depths
inquire (iolength=rec_length) DZBC
!write   (*,*) 'DZBC rec_length', rec_length, imt,jmt
open    (1,file=pbc_file,access='direct',form='unformatted',recl=rec_length,   &
           status='unknown')
  read  (1,rec=1) DZBC ! [cm]
close   (1)
!write   (*,*) 'PBC file: ', pbc_file

! create DZT-field, also used as 3D TTT-mask
do k=1,km
  where(kmT>k)
    DZT(:,:,k) = dz(k)
  elsewhere(kmT==k)
    DZT(:,:,k) = DZBC
  elsewhere
    DZT(:,:,k) = c0
  endwhere
enddo !k

! DZU field
do k=1,km
  do j=1,jmt-1   ! eastern edge
      DZU(imt,j,k) = min(DZT(imt,j,k),DZT(1,j,k),DZT(imt,j+1,k),DZT(1,j+1,k))
    do i=1,imt-1  ! rest of array
      if ( k.le.kmT(i,j) ) then
        DZU(i,j,k) = min(DZT(i,j,k),DZT(i+1,j,k),DZT(i,j+1,k),DZT(i+1,j+1,k))
      endif
    enddo !j
  enddo !j
  ! northern edge
  do i=1,imt-1
    if ( i.lt.imt/2 ) then      ! first half of array, before wrapping around
      DZU(i,j,k) = min( DZT(i,jmt,k),      &
                        DZT(i+1,jmt,k),    &
                        DZT(imt-i,jmt,k),  &
                        DZT(imt-i+1,jmt,k) )
    elseif ( i.gt.imt/2 ) then  ! second half, after wrap
      DZU(i,jmt,k) = DZU(imt-i,jmt,k)
    endif
  enddo !i
enddo !k

!  create tdepth 1D array containing vertical extent of T-cells
open(1,file=in_depths,status='old')
do k = 1, km
  read (1,*) tdz(k)           ! [cm]
  dz(k) = real(tdz(k))/1.0E02 ! to [m]
  !write(*,*) dz(k)
enddo  !k
close(1)

! depths of T-cells
tdepth(1) = dz(1)/2.0
do k = 2,km
  tdepth(k) = tdepth(k-1)+p5*(dz(k-1)+dz(k)) ! [m]
  !write(*,*) tdepth(k)
enddo !k

! (T)area per level [m^2]
do k = 1, km
  area(k) = sum(TAREA,DZT(:,:,k).ne.0.0)/1.0E04 ! [m^2]
!  p_z(k) = pressure(tdepth(k))                ! [bar]
  !write(*,*) area(k), p_z(k)
enddo

! volume per level [m^3] including partial bottom cells
do k=1,km
  vol(k) = sum(DZT(:,:,k)*TAREA(:,:),DZT(:,:,k).ne.0.0)/1.0E06
enddo

!===============================================================================
!  OUTPUT
!===============================================================================

! DXT, DXU
! DYT, DYU
! TAREA, UAREA
! DZT, DZU

open(1,file=geometry1_file,access='direct',form='unformatted',recl=imt*jmt,   &
           status='unknown')

write(1,rec=1) real(DXT/1.0E02)   ! [m]
write(1,rec=2) real(DXU/1.0E02)   ! [m]
write(1,rec=3) real(DYT/1.0E02)   ! [m]
write(1,rec=4) real(DYU/1.0E02)   ! [m]
write(1,rec=5) real(TAREA/1.0E04) ! [m^2]
write(1,rec=6) real(UAREA/1.0E04) ! [m^2]

do k=1,km
  write(1,rec=6+   k) DZT(:,:,k)/1.0E02 ! [m]
  write(1,rec=6+km+k) DZU(:,:,k)/1.0E02 ! [m]
enddo
write(1,rec=91) real(HTN/1.0E02) ! [m]
write(1,rec=92) real(HTE/1.0E02) ! [m]
write(1,rec=93) real(HUS/1.0E02) ! [m]
write(1,rec=94) real(HUW/1.0E02) ! [m]

close(1)

! k, dz, tdepth, area, p, vol
open(2,file=geometry2_file,access='direct',form='unformatted',recl=6,         &
       status='unknown')
do k=1,km
!  write(2,rec=k) real(k),dz(k),tdepth(k),area(k),p_z(k),vol(k)
enddo
close(2)

!===============================================================================
!===============================================================================
end program geometry


program part1
  integer :: n, a, b
  integer, dimension(12) :: bits
  character(len = 12) :: s

  n = 0
  do i = 1, 12
     bits(i) = 0
  end do
  do
     read (5, 12, end=20) s
12   format(a12)
     n = n+1
     do i = 1, 12
        if (s(i:i) == '1') then
           bits(i) = bits(i) + 1
        end if
     end do
  end do
20 a = 0
  b = 0
  do i = 1, 12
     a = a * 2
     b = b * 2
     if (bits(i) > n/2) then
        a = a + 1
     else
        b = b + 1
     end if
  end do
  write(*, '(I0)') a * b
end program part1


module mod_quadratures

!===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         mod_quadratures
 !
 !          Purpose:
 !                   Modern version of Quadpack oscillatory integrators
 !
 !
 !          History:
 !                        Date: 11-05-2019
 !                        Time: 16:52 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !
 !          Author:
 !                piessens,robert,appl. math. & progr. div. - k.u.leuven
 !                de doncker,elise,appl. math. & progr. div. - k.u.leuven
 !
 !          ! Modified by:
 !                           Bernard Gingold on 11-05-2019 16:52 GMT+2
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.

     use mod_kinds, only : int4, dp
     use modprint_error, only : print_non_fatal_error
     implicit none

   contains

     subroutine dqawo(f,a,b,omega,integr,epsabs,epsrel,res,abserr, &
                      neval,ier,leniw,maxp1,lenw,last,iwork,work)
!DIR$ ATTRIBUTES CODE_ALIGN:32 :: dqawo
!              automatic integrator, special-purpose,
!c             integrand with oscillatory cos or sin factor,
!c             clenshaw-curtis method, (end point) singularities,
!c             extrapolation, globally adaptive
!              the routine calculates an approximation result to a given
!c             definite integral i=integral of f(x)*w(x) over (a,b)
!c             where w(x) = cos(omega*x)
!c             or w(x) = sin(omega*x),
!c             hopefully satisfying following claim for accuracy
!c             abs(i-result).le.max(epsabs,epsrel*abs(i)).
           interface
              function f(x) result(v)
                real(kind=dp), intent(in) :: x
                real(kind=dp) :: v
              end function f
           end interface
           real(kind=dp),                        intent(in)    :: a
           real(kind=dp),                        intent(in)    :: b
           real(kind=dp),                        intent(in)    :: omega
           integer(kind=int4),                   intent(in)    :: integr
           real(kind=dp),                        intent(in)    :: epsabs
           real(kind=dp),                        intent(in)    :: epsrel
           real(kind=dp),                        intent(out)   :: res
           real(kind=dp),                        intent(out)   :: abserr
           integer(kind=int4),                   intent(out)   :: neval
           integer(kind=int4),                   intent(inout) :: ier
           integer(kind=int4),                   intent(in)    :: leniw
           integer(kind=int4),                   intent(in)    :: maxp1
           integer(kind=int4),                   intent(in)    :: lenw
           integer(kind=int4),                   intent(iout)  :: last
           integer(kind=int4), dimension(leniw), intent(inout) :: iwork
           real(kind=dp),      dimension(lenw),  intent(in)    :: work
           ! Locals
           integer(kind=int4), automatic :: limit
           integer(kind=int4), automatic :: lvl,l1,l2,l3,l4,momcom
           ! Exec code ....
           ier = 6
           neval = 0
           last  = 0
           res = 0.0_dp
           abserr = 0.0_dp
           if(leniw.lt.2.or.maxp1.lt.1.or.lenw.lt. &
             (leniw*2+maxp1*25)) then
              goto 10
           end if
           limit = leniw/2
           l1 = limit+1
           l2 = limit+l1
           l3 = limit+l2
           l4 = limit+l3
           call DQAWOE(f,a,b,omega,integr,epsabs,epsrel,limit,1,maxp1,res,&
                       abserr,neval,ier,last,work(1),work(l1),work(l2),work(l3),&
                       iwork(1),iwork(l1),momcom,work(l4))
           lvl = 6
10         if(ier == 6) lvl = 0
           if(ier /= 0) then
              call print_non_fatal_error((" ================= Non-Fatal ================== " , &
                                            " Module: mod_quadratures, subroutine: dqawo: abnormal return from dqawo ! ",  &
                                            __LINE__,__FILE__ )
              return
           end if
     end subroutine dqawo

     subroutine dqawoe(f,a,b,omega,integr,epsabs,epsrel,limit,icall,maxp1,res, &
                       abserr,neval,ier,last,alist,blist,rlist,elist,iord,nnlog, &
                       momcom,chebmo)
!DIR$ ATTRIBUTES CODE_ALIGN:32 :: dqawoe
!              automatic integrator, special-purpose,
!c             integrand with oscillatory cos or sin factor,
!c             clenshaw-curtis method, (end point) singularities,
!c             extrapolation, globally adaptive
!              the routine calculates an approximation result to a given
!c             definite integral
!c             i = integral of f(x)*w(x) over (a,b)
!c             where w(x) = cos(omega*x) or w(x)=sin(omega*x),
!c             hopefully satisfying following claim for accuracy
!c             abs(i-result).le.max(epsabs,epsrel*abs(i)).
           use mod_machine_prec, only : d1mach
           interface
               function f(x) result(v)
                 real(kind=dp),  intent(in) :: x
                 real(kind=dp) :: v
               end function f
           end interface
           real(kind=dp),                             intent(in)    :: a
           real(kind=dp),                             intent(in)    :: b
           real(kind=dp),                             intent(in)    :: omega
           integer(kind=int4),                        intent(in)    :: integr
           real(kind=dp),                             intent(in)    :: epsabs
           real(kind=dp),                             intent(in)    :: epsrel
           integer(kind=int4),                        intent(in)    :: limit
           integer(kind=int4),                        intent(in)    :: icall
           integer(kind=int4),                        intent(in)    :: maxp1
           real(kind=dp),                             intent(out)   :: res
           real(kind=dp),                             intent(out)   :: abserr
           integer(kind=int4),                        intent(out)   :: neval
           integer(kind=int4),                        intent(out)   :: ier
           real(kind=dp),      dimension(limit),      intent(inout) :: alist
           real(kind=dp),      dimension(limit),      intent(inout) :: blist
           real(kind=dp),      dimension(limit),      intent(inout) :: rlist
           real(kind=dp),      dimension(limit),      intent(inout) :: elist
           integer(kind=int4), dimension(limit),      intent(inout) :: iord
           integer(kind=int4), dimension(limit),      intent(inout) :: nnlog
           integer(kind=int4),                        intent(inout) :: momcom
           real(kind=dp),      dimension(maxp1,25),   intent(inout) :: chebmo
           ! LOcals
!DIR$      ATTRIBUTES ALIGN : 64 :: rlist2
           real(kind=dp), automatic, dimension(52) :: rlist2
           real(kind=dp), automatic, dimension(3)  :: res3la
           real(kind=dp),  automatic ::  abseps,area,area1,area12,area2,a1,a2,b,b1,b2, &
                            correc,dabs,defab1,defab2,defabs,domega,dres, &
                            epmach,erlarg,erlast,errbnd,errmax,error1,    &
                            error12,error2,errsum,ertest,oflow,reseps,    &
                            small,uflow,width
           integer(kind=int4),automatic  :: id, ierro,iroff1,iroff2,iroff3,jupbnd,k,ksg, &
                ktmin,maxerr,nev,nres,nrmax,nrmom,numrl2
           logical(kind=int4), automatic :: extrap,noext,extall
           ! Exec code .....
           epmach = d1mach(4)
           ier    = 0
           neval  = 0
           last   = 0
           res    = 0.0e+00_dp
           abserr = 0.0e+00_dp
           alist(1) = a
           blist(1) = b
           rlist(1) = 0.0e+00_dp
           elist(1) = 0.0e+00_dp
           iord(1)  = 0
           nnlog(1) = 0
           if((integr.ne.1.and.integr.ne.2).or.(epsabs.le.0.0d+00.and.     &
               epsrel.lt.DMAX1(0.5d+02*epmach,0.5d-28)).or.icall.lt.1.or.  &
               maxp1.lt.1) ier = 6
           if(ier == 6) goto 999
           domega = ABS(omega)
           nrmom  = 0
           if(icall.gt.1) goto 5
           momcom = 0
5          call DQC25F(f,a,b,domega,integr,nrmom,maxp1,0,result,abserr,   &
                neval,defabs,resabs,momcom,chebmo)
           dres = ABS(res)
           errbnd = MAX(epsabs,epsrel*dres)
           rlist(1) = res
           elist(1) = abserr
           iord(1) = 1
           if(abserr.le.0.1d+03*epmach*defabs.and.abserr.gt.errbnd) ier = 2
           if(limit.eq.1) ier = 1
           if(ier.ne.0.or.abserr.le.errbnd) go to 200
           uflow = d1mach(1)
           oflow = d1mach(2)
           errmax = abserr
           maxerr = 1
           area = res
           errsum = abserr
           abserr = oflow
           nrmax = 1
           extrap = .false.
           noext = .false.
           ierro = 0
           iroff1 = 0
           iroff2 = 0
           iroff3 = 0
           ktmin = 0
           small = ABS(b-a)*0.75_dp
           nres = 0
           numrl2 = 0
           extall = .false.
           if(0.5e+00_dp*ABS(b-a)*domega.gt.0.2d+01) go to 10
           numrl2 = 1
           extall = .true.
           rlist2(1) = res
10         if(0.25_dp*ABS(b-a)*domega.le.0.2d+01) extall = .true.
           ksgn = -1
           if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1
           do 140 last = 2,limit
!c
!c           bisect the subinterval with the nrmax-th largest
!c           error estimate.
!c
                     nrmom = nnlog(maxerr)+1
                     a1 = alist(maxerr)
                     b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
                     a2 = b1
                     b2 = blist(maxerr)
                     erlast = errmax
                     call DQC25F(f,a1,b1,domega,integr,nrmom,maxp1,0,  &
                                 area1,error1,nev,resabs,defab1,momcom,chebmo)
                     neval = neval+nev
                     call DQC25F(f,a2,b2,domega,integr,nrmom,maxp1,1,  &
                                 area2,error2,nev,resabs,defab2,momcom,chebmo)
                     neval = neval+nev
!c
!c           improve previous approximations to integral
!c           and error and test for accuracy.
!c
                     area12 = area1+area2
                     erro12 = error1+error2
                     errsum = errsum+erro12-errmax
                     area = area+area12-rlist(maxerr)
                     if(defab1.eq.error1.or.defab2.eq.error2) go to 25
                     if(DABS(rlist(maxerr)-area12).gt.0.1d-04*DABS(area12)   &
                                          .or.erro12.lt.0.99d+00*errmax) go to 20
                     if(extrap) iroff2 = iroff2+1
                     if(.not.extrap) iroff1 = iroff1+1
20                   if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1
25                   rlist(maxerr) = area1
                     rlist(last) = area2
                     nnlog(maxerr) = nrmom
                     nnlog(last) = nrmom
                     errbnd = MAX(epsabs,epsrel*DABS(area))
!c
!c           test for roundoff error and eventually set error flag.
!c
                     if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2
                     if(iroff2.ge.5) ierro = 3
!c
!c           set error flag in the case that the number of
!c           subintervals equals limit.
!c
                     if(last.eq.limit) ier = 1
!c
!c           set error flag in the case of bad integrand behaviour
!c           at a point of the integration range.
!c
                     if(DMAX1(DABS(a1),DABS(b2)).le.(0.1d+01+0.1d+03*epmach) *  &
                       (DABS(a2)+0.1d+04*uflow)) ier = 4
!c
!c           append the newly-created intervals to the list.
!c
                     if(error2.gt.error1) go to 30
                     alist(last) = a2
                     blist(maxerr) = b1
                     blist(last) = b2
                     elist(maxerr) = error1
                     elist(last) = error2
                     go to 40
30                   alist(maxerr) = a2
                     alist(last) = a1
                     blist(last) = b1
                     rlist(maxerr) = area2
                     rlist(last) = area1
                     elist(maxerr) = error2
                     elist(last) = error1
!c
!c           call subroutine dqpsrt to maintain the descending ordering
!c           in the list of error estimates and select the subinterval
!c           with nrmax-th largest error estimate (to bisected next).
!c
40                   call DQPSRT(limit,last,maxerr,errmax,elist,iord,nrmax)
!c ***jump out of do-loop
                     if(errsum.le.errbnd) go to 170
                     if(ier.ne.0) go to 150
                     if(last.eq.2.and.extall) go to 120
                     if(noext) go to 140
                     if(.not.extall) go to 50
                     erlarg = erlarg-erlast
                     if(DABS(b1-a1).gt.small) erlarg = erlarg+erro12
                     if(extrap) go to 70
!c
!c           test whether the interval to be bisected next is the
!c           smallest interval.
!c
50                    width = DABS(blist(maxerr)-alist(maxerr))
                      if(width.gt.small) go to 140
                      if(extall) go to 60
!c
!c           test whether we can start with the extrapolation procedure
!c           (we do this if we integrate over the next interval with
!c           use of a gauss-kronrod rule - see subroutine dqc25f).
!c
                      small = small*0.5d+00
                      if(0.25d+00*width*domega.gt.0.2d+01) go to 140
                      extall = .true.
                      go to 130
60                    extrap = .true.
                      nrmax = 2
70                    if(ierro.eq.3.or.erlarg.le.ertest) go to 90
!c
!c           the smallest interval has the largest error.
!c           before bisecting decrease the sum of the errors over
!c           the larger intervals (erlarg) and perform extrapolation.
!c
                     jupbnd = last
                     if (last.gt.(limit/2+2)) jupbnd = limit+3-last
                     id = nrmax
                     do 80 k = id,jupbnd
                               maxerr = iord(nrmax)
                               errmax = elist(maxerr)
                               if(DABS(blist(maxerr)-alist(maxerr)).gt.small) go to 140
                                  nrmax = nrmax+1
80                   continue
!c
!c           perform extrapolation.
!c
90                   numrl2 = numrl2+1
                     rlist2(numrl2) = area
                     if(numrl2.lt.3) go to 110
                     call DQELG(numrl2,rlist2,reseps,abseps,res3la,nres)
                     ktmin = ktmin+1
                     if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5
                     if(abseps.ge.abserr) go to 100
                     ktmin = 0
                     abserr = abseps
                     res    = reseps
                     correc = erlarg
                     ertest = MAX(epsabs,epsrel*DABS(reseps))
!c ***jump out of do-loop
                     if(abserr.le.ertest) go to 150
!c
!c           prepare bisection of the smallest interval.
!c
100                  if(numrl2.eq.1) noext = .true.
                     if(ier.eq.5) go to 150
110                  maxerr = iord(1)
                     errmax = elist(maxerr)
                     nrmax = 1
                     extrap = .false.
                     small = small*0.5d+00
                     erlarg = errsum
                     go to 140
120                  small = small*0.5d+00
                     numrl2 = numrl2+1
                     rlist2(numrl2) = area
130                  ertest = errbnd
                     erlarg = errsum
140        continue
!c
!c           set the final result.
!c           ---------------------
!c
  150      if(abserr.eq.oflow.or.nres.eq.0) go to 170
           if(ier+ierro.eq.0) go to 165
           if(ierro.eq.3) abserr = abserr+correc
           if(ier.eq.0) ier = 3
           if(result.ne.0.0d+00.and.area.ne.0.0d+00) go to 160
           if(abserr.gt.errsum) go to 170
           if(area.eq.0.0d+00) go to 190
           go to 165
160        if(abserr/DABS(res).gt.errsum/DABS(area)) go to 170
!c
!c           test on divergence.
!c
165        if(ksgn.eq.(-1).and.MAX(ABS(res),ABS(area)).le.  &
               defabs*0.1d-01) go to 190
           if(0.1d-01.gt.(res/area).or.(res/area).gt.0.1d+03 &
                 .or.errsum.ge.DABS(area)) ier = 6
           go to 190
!c
!c           compute global integral sum.
!c
170        res = 0.0d+00
           do 180 k=1,last
                   res = res+rlist(k)
180        continue
           abserr = errsum
190        if (ier.gt.2) ier=ier-1
200        if (integr.eq.2.and.omega.lt.0.0d+00) res = -res

     end subroutine dqawoe

     subroutine dqc25f(f,a,b,omega,integr,nrmom,maxp1,ksave,res,abserr, &
                       neval,resabs,resasc,momcom,chebmo)
!DIR$ ATTRIBUTES CODE_ALIGN:32 :: dqc25f
!              integration rules for functions with cos or sin
!c             factor, clenshaw-curtis, gauss-kronrod
!             to compute the integral i=integral of f(x) over (a,b)
!c            where w(x) = cos(omega*x) or w(x)=sin(omega*x) and to
!c            compute j = integral of abs(f) over (a,b). for small value
!c            of omega or small intervals (a,b) the 15-point gauss-kronro
!c            rule is used. otherwise a generalized clenshaw-curtis
       !c            method is used.
           use mod_machine_prec, only : d1mach
           interface
              function f(x) result(v)
                real(kind=dp), intent(in) :: x
                real(kind=dp) :: v
              end function f
           end interface
           real(kind=dp),                      intent(in) :: a
           real(kind=dp),                      intent(in) :: b
           real(kind=dp),                      intent(in) :: omega
           integer(kind=int4),                 intent(in) :: integr
           integer(kind=int4),                 intent(in) :: nrmom
           integer(kind=int4),                 intent(in) :: maxp1
           integer(kind=int4),                 intent(in) :: ksave
           real(kind=dp),                      intent(out) :: res
           real(kind=dp),                      intent(out) :: abserr
           integer(kind=int4),                 intent(out) :: neval
           real(kind=dp),                      intent(out) :: resabs
           real(kind=dp),                      intent(out) :: resasc
           integer(kind=int4),                 intent(inout) :: momcom
           real(kind=dp), dimension(maxp1,25), intent(inout) :: chebmo
           ! LOcals
           real(kind=dp), dimension(11), parameter ::  x = [ 0.991444861373810411144557526928563_dp,    &
                                                             0.965925826289068286749743199728897_dp,    &
                                                             0.923879532511286756128183189396788_dp,    &
                                                             0.866025403784438646763723170752936_dp,    &
                                                             0.793353340291235164579776961501299_dp,    &
                                                             0.707106781186547524400844362104849_dp,    &
                                                             0.608761429008720639416097542898164_dp,    &
                                                             0.500000000000000000000000000000000_dp,    &
                                                             0.382683432365089771728459984030399_dp,    &
                                                             0.258819045102520762348898837624048_dp,    &
                                                             0.130526192220051591548406227895489  ]
           real(kind=dp), automatic, dimension(13) ::  cheb12
           real(kind=dp), automatic, dimension(25) ::  cheb24
           real(kind=dp), automatic, dimension(25) ::  d,d1,d2,fval
           real(kind=dp), automatic, dimension(28) ::  v
           real(kind=dp), automatic :: ac,an,an2,as,asap,ass,centr,conc,cons, &
                                       cospar,estc,ests,hlgth,ovflow,parint,  &
                                       par2,par22,p2,p3,p4,resc12,resc24,ress24, &
                                       sinpar
           integer(kind=int4), automatic :: i,iers,isym,j,k,ksym,m,noequ,noeq1
           external dqwgtf
!                  list of major variables
!c           -----------------------
!c
!c           centr  - mid point of the integration interval
!c           hlgth  - half-length of the integration interval
!c           fval   - value of the function f at the points
!c                    (b-a)*0.5*cos(k*pi/12) + (b+a)*0.5, k = 0, ..., 24
!c           cheb12 - coefficients of the chebyshev series expansion
!c                    of degree 12, for the function f, in the
!c                    interval (a,b)
!c           cheb24 - coefficients of the chebyshev series expansion
!c                    of degree 24, for the function f, in the
!c                    interval (a,b)
!c           resc12 - approximation to the integral of
!c                    cos(0.5*(b-a)*omega*x)*f(0.5*(b-a)*x+0.5*(b+a))
!c                    over (-1,+1), using the chebyshev series
!c                    expansion of degree 12
!c           resc24 - approximation to the same integral, using the
!c                    chebyshev series expansion of degree 24
!1c           ress12 - the analogue of resc12 for the sine
!c           ress24 - the analogue of resc24 for the sine
!c
!c
!c           machine dependent constant
!c           --------------------------
!c
!c           oflow is the largest positive magnitude.
           oflow = d1mach
           centr = 0.5e+00_dp*(b+a)
           hlgth = 0.5e+00_dp*(b-a)
           parint = omega*hlgth
!c
!c           compute the integral using the 15-point gauss-kronrod
!c           formula if the value of the parameter in the integrand
!c           is small.
!c
           if(ABS(parint).gt.0.2d+01) go to 10
           call dqk15w(f,dqwgtf,omega,p2,p3,p4,integr,a,b,res,abserr,resabs,resasc)

           neval = 15
           go to 170
!c
!c           compute the integral using the generalized clenshaw-
!c           curtis method.
!c
10         conc = hlgth*COS(centr*omega)
           cons = hlgth*SIN(centr*omega)
           resasc = oflow
           neval = 25
!c
!c           check whether the chebyshev moments for this interval
!c           have already been computed.
!c
           if(nrmom.lt.momcom.or.ksave.eq.1) go to 120
!                    compute a new set of chebyshev moments.

           m = momcom+1
           par2 = parint*parint
           par22 = par2+0.2d+01
           sinpar = SIN(parint)
           cospar = COS(parint)
!c
!c           compute the chebyshev moments with respect to cosine.
!c
           v(1) = 0.2d+01*sinpar/parint
           v(2) = (0.8d+01*cospar+(par2+par2-0.8d+01)*sinpar/parint)/par2
           v(3) = (0.32d+02*(par2-0.12d+02)*cospar+(0.2d+01*  &
                  ((par2-0.80d+02)*par2+0.192d+03)*sinpar)/parint)/(par2*par2)
           ac = 0.8d+01*cospar
           as = 0.24d+02*parint*sinpar
           if(DABS(parint).gt.0.24d+02) go to 30
!c
!c           compute the chebyshev moments as the solutions of a
!c           boundary value problem with 1 initial value (v(3)) and 1
!c           end value (computed using an asymptotic formula).
           !c
           noequ = 25
           noeq1 = noequ-1
           an = 0.6d+01
           do 20 k = 1,noeq1
                 an2 = an*an
                 d(k) = -0.2d+01*(an2-0.4d+01)*(par22-an2-an2)
                 d2(k) = (an-0.1d+01)*(an-0.2d+01)*par2
                 d1(k+1) = (an+0.3d+01)*(an+0.4d+01)*par2
                 v(k+3) = as-(an2-0.4d+01)*ac
                 an = an+0.2d+01
       20  continue
           an2 = an*an
           d(noequ) = -0.2d+01*(an2-0.4d+01)*(par22-an2-an2)
           v(noequ+3) = as-(an2-0.4d+01)*ac
           v(4) = v(4)-0.56d+02*par2*v(3)
           ass = parint*sinpar
           asap = (((((0.210d+03*par2-0.1d+01)*cospar-(0.105d+03*par2       &
                     -0.63d+02)*ass)/an2-(0.1d+01-0.15d+02*par2)*cospar    &
                     +0.15d+02*ass)/an2-cospar+0.3d+01*ass)/an2-cospar)/an2
           v(noequ+3) = v(noequ+3)-0.2d+01*asap*par2*(an-0.1d+01)*(an-0.2d+01)

!1c
!c           solve the tridiagonal system by means of gaussian
!c           elimination with partial pivoting.
!c
!c***        call to dgtsl must be replaced by call to
!c***        double precision version of linpack routine sgtsl
!c
           call dgtsl(noequ,d1,d,d2,v(4),iers)
           go to 50
            compute the chebyshev moments by means of forward
!c           recursion.
!c
30         an = 0.4d+01
           do 40 i = 4,13
           an2 = an*an
           v(i) = ((an2-0.4d+01)*(0.2d+01*(par22-an2-an2)*v(i-1)-ac)  &
           + as-par2*(an+0.1d+01)*(an+0.2d+01)*v(i-2))/               &
           (par2*(an-0.1d+01)*(an-0.2d+01))
           an = an+0.2d+01
   40      continue
   50      do 60 j = 1,13
                 chebmo(m,2*j-1) = v(j)
   60      continue
!c
!c           compute the chebyshev moments with respect to sine.
!c
           v(1) = 0.2d+01*(sinpar-parint*cospar)/par2
           v(2) = (0.18d+02-0.48d+02/par2)*sinpar/par2  &
           + (-0.2d+01+0.48d+02/par2)*cospar/parint
           ac = -0.24d+02*parint*cospar
           as = -0.8d+01*sinpar
           if(ABS(parint).gt.0.24d+02) go to 80
!c
!c           compute the chebyshev moments as the solutions of a boundary
!c           value problem with 1 initial value (v(2)) and 1 end value
!c           (computed using an asymptotic formula).
!c
           an = 0.5d+01
           do 70 k = 1,noeq1
                   an2 = an*an
                   d(k) = -0.2d+01*(an2-0.4d+01)*(par22-an2-an2)
                   d2(k) = (an-0.1d+01)*(an-0.2d+01)*par2
                   d1(k+1) = (an+0.3d+01)*(an+0.4d+01)*par2
                   v(k+2) = ac+(an2-0.4d+01)*as
                   an = an+0.2d+01
   70      continue
           an2 = an*an
           d(noequ) = -0.2d+01*(an2-0.4d+01)*(par22-an2-an2)
           v(noequ+2) = ac+(an2-0.4d+01)*as
           v(3) = v(3)-0.42d+02*par2*v(2)
           ass = parint*cospar
           asap = (((((0.105d+03*par2-0.63d+02)*ass+(0.210d+03*par2       &
                  -0.1d+01)*sinpar)/an2+(0.15d+02*par2-0.1d+01)*sinpar-   &
                   0.15d+02*ass)/an2-0.3d+01*ass-sinpar)/an2-sinpar)/an2
           v(noequ+2) = v(noequ+2)-0.2d+01*asap*par2*(an-0.1d+01)         &
           *(an-0.2d+01)
!c
!c           solve the tridiagonal system by means of gaussian
!c           elimination with partial pivoting.
!c
!c***        call to dgtsl must be replaced by call to
!c***        double precision version of linpack routine sgtsl
!c
           call dgtsl(noequ,d1,d,d2,v(3),iers)
           go to 100
!c
!c           compute the chebyshev moments by means of forward recursion.
!c
   80      an = 0.3d+01
           do 90 i = 3,12
                   an2 = an*an
                   v(i) = ((an2-0.4d+01)*(0.2d+01*(par22-an2-an2)*v(i-1)+as)   &
                          +ac-par2*(an+0.1d+01)*(an+0.2d+01)*v(i-2))           &
                          /(par2*(an-0.1d+01)*(an-0.2d+01))
                   an = an+0.2d+01
   90      continue
  100      do 110 j = 1,12
                   chebmo(m,2*j) = v(j)
  110      continue
  120      if (nrmom.lt.momcom) m = nrmom+1
           if (momcom.lt.(maxp1-1).and.nrmom.ge.momcom) momcom = momcom+1
!c
!c           compute the coefficients of the chebyshev expansions
!c           of degrees 12 and 24 of the function f.
!c
           fval(1) = 0.5d+00*f(centr+hlgth)
           fval(13) = f(centr)
           fval(25) = 0.5d+00*f(centr-hlgth)
           do 130 i = 2,12
                    isym = 26-i
                    fval(i) = f(hlgth*x(i-1)+centr)
                    fval(isym) = f(centr-hlgth*x(i-1))
  130      continue
           call DQCHEB(x,fval,cheb12,cheb24)
!c
!c           compute the integral and error estimates.
!c
           resc12 = cheb12(13)*chebmo(m,13)
           ress12 = 0.0d+00
           k = 11
           do 140 j = 1,6
                   resc12 = resc12+cheb12(k)*chebmo(m,k)
                   ress12 = ress12+cheb12(k+1)*chebmo(m,k+1)
                   k = k-2
  140      continue
           resc24 = cheb24(25)*chebmo(m,25)
           ress24 = 0.0d+00
           resabs = ABS(cheb24(25))
           k = 23
           do 150 j = 1,12
                 resc24 = resc24+cheb24(k)*chebmo(m,k)
                 ress24 = ress24+cheb24(k+1)*chebmo(m,k+1)
                 resabs = ABS(cheb24(k))+DABS(cheb24(k+1))
                 k = k-2
  150      continue
           estc = ABS(resc24-resc12)
           ests = ABS(ress24-ress12)
           resabs = resabs*ABS(hlgth)
           if(integr.eq.2) go to 160
           res = conc*resc24-cons*ress24
           abserr = ABS(conc*estc)+ABS(cons*ests)
           go to 170
  160      res = conc*ress24+cons*resc24
           abserr = DABS(conc*ests)+DABS(cons*estc)

     end subroutine dqc25f

     subroutine dqk15w(f,w,p1,p2,p3,p4,kp,a,b,res,abserr,resabs,resasc)
       !DIR$ ATTRIBUTES CODE_ALIGN:32 :: dqk15w
!        to compute i = integral of f*w over (a,b), with error
       !c                           estimate
       !c                       j = integral of abs(f*w) over (a,b)
           use mod_machine_prec, only : d1mach
           interface
              function f(x) result(v)
                real(kind=dp), intent(in) :: x
                real(kind=dp) :: v
              end function f
           end interface
           interface
              function w(x,omega,p2,p3,p4,integr) result(v)
                real(kind=dp), intent(in) :: x
                real(kind=dp), intent(in) :: omega
                real(kind=dp), intent(in) :: p2
                real(kind=dp), intent(in) :: p3
                real(kind=dp), intent(in) :: p4
                integer(kind=int4), intent(in) :: integr
                real(kind=dp), intent(in) :: integr
              end function w
           end interface
           real(kind=dp),      intent(in) :: p1
           real(kind=dp),      intent(in) :: p2
           real(kind=dp),      intent(in) :: p3
           real(kind=dp),      intent(in) :: p4
           integer(kind=dint4), intent(in) :: kp
           real(kind=dp),       intent(in) :: a
           real(kind=dp),       intent(in) :: b
           real(kind=dp),       intent(inout) :: res
           real(kind=dp),       intent(inout) :: abserr
           real(kind=dp),       intent(inout) :: resabs
           real(kind=dp),       intent(inout) :: resasc
           !Locals
           real(kind=dp), dimension(8), parameter :: xgk = [0.9914553711208126e+00_dp,0.9491079123427585e+00_dp, &
                                                            0.8648644233597691e+00_dp,0.7415311855993944e+00_dp, &
                                                            0.5860872354676911e+00_dp,0.4058451513773972e+00_dp, &
                                                            0.2077849550078985e+00_dp,0.0000000000000000e+00_dp]
           real(kind=dp), dimension(8), parameter :: wgk = [0.2293532201052922e-01_dp,0.6309209262997855e-01_dp,&
                                                            0.1047900103222502e+00_dp,0.1406532597155259e+00_dp,&
                                                            0.1690047266392679e+00_dp,0.1903505780647854e+00_dp,&
                                                            0.2044329400752989e+00_dp,0.2094821410847278e+00_dp]
           real(kind=dp), dimension(4), parameter :: wg  = [ 0.1294849661688697e+00_dp,0.2797053914892767e+00_dp,&
                                                             0.3818300505051889e+00_dp,0.4179591836734694e+00_dp]
           real(kind=dp), automatic, dimension(7) :: fv1,fv2
           real(kind=dp), automatic :: absc,absc1,absc2,centr,dhlgth,epmach,fc, &
                                       fsum,fval1,fval2,hlgth,resg,resk,reskh,uflow
           ! Exec code .....
           epmach = d1mach(4)
           uflow  = d1mach(1)
           centr = 0.5e+00_dp*(a+b)
           hlgth = 0.5e+00_dp*(b-a)
           dhlgth = ABS(hlgth)
!c
!c           compute the 15-point kronrod approximation to the
!c           integral, and estimate the error.
!c
           fc = f(centr)*w(centr,p1,p2,p3,p4,kp)
           resg = wg(4)*fc
           resk = wgk(8)*fc
           resabs = ABS(resk)
           fv1 = 0.0_dp
           fv2 = 0.0_dp
           do 10 j=1,3
                 jtw = j*2
                 absc = hlgth*xgk(jtw)
                 absc1 = centr-absc
                 absc2 = centr+absc
                 fval1 = f(absc1)*w(absc1,p1,p2,p3,p4,kp)
                 fval2 = f(absc2)*w(absc2,p1,p2,p3,p4,kp)
                 fv1(jtw) = fval1
                 fv2(jtw) = fval2
                 fsum = fval1+fval2
                 resg = resg+wg(j)*fsum
                 resk = resk+wgk(jtw)*fsum
                 resabs = resabs+wgk(jtw)*(ABS(fval1)+ABS(fval2))
   10      continue
           do 15 j=1,4
                 jtwm1 = j*2-1
                 absc = hlgth*xgk(jtwm1)
                 absc1 = centr-absc
                 absc2 = centr+absc
                 fval1 = f(absc1)*w(absc1,p1,p2,p3,p4,kp)
                 fval2 = f(absc2)*w(absc2,p1,p2,p3,p4,kp)
                 fv1(jtwm1) = fval1
                 fv2(jtwm1) = fval2
                 fsum = fval1+fval2
                 resk = resk+wgk(jtwm1)*fsum
                 resabs = resabs+wgk(jtwm1)*(ABS(fval1)+ABS(fval2))
     15    continue
           reskh = resk*0.5e+00_dp
           resasc = wgk(8)*DABS(fc-reskh)
           do 20 j=1,7
                resasc = resasc+wgk(j)*(ABS(fv1(j)-reskh)+ABS(fv2(j)-reskh))
   20       continue
            res = resk*hlgth
            resabs = resabs*dhlgth
            resasc = resasc*dhlgth
            abserr = ABS((resk-resg)*hlgth)
            if(resasc.ne.0.0e+00_dp.and.abserr.ne.0.0e+00_dp)  &
                abserr = resasc*MIN(0.1e+01_dp,(0.2e+03_dp*abserr/resasc)**1.5e+00_dp)
            if(resabs.gt.uflow/(0.5e+02_dp*epmach)) abserr = MAX((epmach*0.5e+02_dp)*resabs,abserr)

     end subroutine dqk15w

     function dqwgtf(x,omega,p2,p3,p4,integr) result(res)
!DIR$ ATTRIBUTES CODE_ALIGN:32 :: dqwgtf
           real(kind=dp),      intent(in) :: x
           real(kind=dp),      intent(in) :: omega
           real(kind=dp),      intent(in) :: p2
           real(kind=dp),      intent(in) :: p3
           real(kind=dp),      intent(in) :: p4
           integer(kind=int4), intent(in) :: integr
           ! Locals/return
           real(kind=dp) :: res
           real(kind=dp), automatic :: omx
           ! Exec code ....
           omx = omega*x
           if(10 == integr) then
              res = cos(omx)
           else if(20 == integr) then
              res = sin(omx)
           end if
     end function dqwgtf

     subroutine dgtsl(n,c,d,e,b,info)
!DIR$ ATTRIBUTES CODE_ALIGN:32 :: dgtsl
       integer(kind=int4),          intent(in) ::  n
       real(kind=dp), dimension(n), intent(in) :: c
       real(kind=dp), dimension(n), intent(in) :: d
       real(kind=dp), dimension(n), intent(in) :: e
       real(kind=dp), dimension(n), intent(inout) :: b
       integer(kind=int4),          intent(inout) :: info

!c
!c     dgtsl given a general tridiagonal matrix and a right hand
!c     side will find the solution.
!c
!c     on entry
!c
!c        n       integer
!c                is the order of the tridiagonal matrix.
!c
!c        c       double precision(n)
!c                is the subdiagonal of the tridiagonal matrix.
!c                c(2) through c(n) should contain the subdiagonal.
!c                on output c is destroyed.
!c
!c        d       double precision(n)
!c                is the diagonal of the tridiagonal matrix.
!c                on output d is destroyed.
!c
!c        e       double precision(n)
!c                is the superdiagonal of the tridiagonal matrix.
!c                e(1) through e(n-1) should contain the superdiagonal.
!c                on output e is destroyed.
!c
!c        b       double precision(n)
!c                is the right hand side vector.
!c
!c     on return
!c
!c        b       is the solution vector.
!c
!c        info    integer
!c                = 0 normal value.
!c                = k if the k-th element of the diagonal becomes
!c                    exactly zero.  the subroutine returns when
!c                    this is detected.
!c
!c     linpack. this version dated 08/14/78 .
!c     jack dongarra, argonne national laboratory.
!c
!c     no externals
!c     fortran dabs
!c
!c     internal variables
       !c

           integer(kind=int4), automatic ::  k,kb,kp1,nm1,nm2
           real(kind=dp), automatic ::       t
!c     begin block permitting ...exits to 100

           info = 0
           c(1) = d(1)
           nm1 = n - 1
           if (nm1 .lt. 1) go to 40
              d(1) = e(1)
              e(1) = 0.0_dp
              e(n) = 0.0_dp

            do 30 k = 1, nm1
               kp1 = k + 1

!c              find the largest of the two rowsc
               if (abs(c(kp1)) .lt. abs(c(k))) go to 10
!c
!c                 interchange row
!c
                  t = c(kp1)
                  c(kp1) = c(k)
                  c(k) = t
                  t = d(kp1)
                  d(kp1) = d(k)
                  d(k) = t
                  t = e(kp1)
                  e(kp1) = e(k)
                  e(k) = t
                  t = b(kp1)
                  b(kp1) = b(k)
                  b(k) = t
   10          continue
!c
!c              zero elements
!c
               if (c(k) .ne. 0.0_dp) go to 20
                  info = k
!c     ............exit
                  go to 100
   20          continue
               t = -c(kp1)/c(k)
               c(kp1) = d(kp1) + t*d(k)
               d(kp1) = e(kp1) + t*e(k)
               e(kp1) = 0.0_dp
               b(kp1) = b(kp1) + t*b(k)
   30       continue
   40    continue
         if (c(n) .ne. 0.0_dp) go to 50
            info = n
         go to 90
   50    continue
!c
!c           back solve
!c
            nm2 = n - 2
            b(n) = b(n)/c(n)
            if (n .eq. 1) go to 80
               b(nm1) = (b(nm1) - d(nm1)*b(n))/c(nm1)
               if (nm2 .lt. 1) go to 70
               do 60 kb = 1, nm2
                  k = nm2 - kb + 1
                  b(k) = (b(k) - d(k)*b(k+1) - e(k)*b(k+2))/c(k)
   60          continue
   70          continue
   80       continue
   90    continue
100    continue

     end subroutine dgtsl

     subroutine dqcheb(x,fval,cheb12,cheb24)
!DIR$ ATTRIBUTES ALIGN:32 :: dqcheb
           real(kind=dp), dimension(11), intent(in) :: x
           real(kind=dp), dimension(25), intent(in) :: fval
           real(kind=dp), dimension(13), intent(inout) :: cheb12
           real(kind=dp), dimension(25), intent(inout) :: cheb24
           ! LOcals
           real(kind=dp), automatic, dimension(12) :: v
           real(kind=dp), automatic :: alam,alam1,alam2,part1,part2
           integer(kind=int4), automatic :: i,j
           ! Exec code ......
           do 10 i=1,12
                 j = 26-i
                 v(i) = fval(i)-fval(j)
                 fval(i) = fval(i)+fval(j)
   10      continue
           alam1 = v(1)-v(9)
           alam2 = x(6)*(v(3)-v(7)-v(11))
           cheb12(4) = alam1+alam2
           cheb12(10) = alam1-alam2
           alam1 = v(2)-v(8)-v(10)
           alam2 = v(4)-v(6)-v(12)
           alam = x(3)*alam1+x(9)*alam2
           cheb24(4) = cheb12(4)+alam
           cheb24(22) = cheb12(4)-alam
           alam = x(9)*alam1-x(3)*alam2
           cheb24(10) = cheb12(10)+alam
           cheb24(16) = cheb12(10)-alam
           part1 = x(4)*v(5)
           part2 = x(8)*v(9)
           part3 = x(6)*v(7)
           alam1 = v(1)+part1+part2
           alam2 = x(2)*v(3)+part3+x(10)*v(11)
           cheb12(2) = alam1+alam2
           cheb12(12) = alam1-alam2
           alam = x(1)*v(2)+x(3)*v(4)+x(5)*v(6)+x(7)*v(8) &
                 +x(9)*v(10)+x(11)*v(12)
           cheb24(2) = cheb12(2)+alam
           cheb24(24) = cheb12(2)-alam
           alam = x(11)*v(2)-x(9)*v(4)+x(7)*v(6)-x(5)*v(8) &
                 +x(3)*v(10)-x(1)*v(12)
           cheb24(12) = cheb12(12)+alam
           cheb24(14) = cheb12(12)-alam
           alam1 = v(1)-part1+part2
           alam2 = x(10)*v(3)-part3+x(2)*v(11)
           cheb12(6) = alam1+alam2
           cheb12(8) = alam1-alam2
           alam = x(5)*v(2)-x(9)*v(4)-x(1)*v(6) &
                 -x(11)*v(8)+x(3)*v(10)+x(7)*v(12)
           cheb24(6) = cheb12(6)+alam
           cheb24(20) = cheb12(6)-alam
           alam = x(7)*v(2)-x(3)*v(4)-x(11)*v(6)+x(1)*v(8) &
                 -x(9)*v(10)-x(5)*v(12)
           cheb24(8) = cheb12(8)+alam
           cheb24(18) = cheb12(8)-alam
           do 20 i=1,6
                 j = 14-i
                 v(i) = fval(i)-fval(j)
                 fval(i) = fval(i)+fval(j)
   20      continue
           alam1 = v(1)+x(8)*v(5)
           alam2 = x(4)*v(3)
           cheb12(3) = alam1+alam2
           cheb12(11) = alam1-alam2
           cheb12(7) = v(1)-v(5)
           alam = x(2)*v(2)+x(6)*v(4)+x(10)*v(6)
           cheb24(3) = cheb12(3)+alam
           cheb24(23) = cheb12(3)-alam
           alam = x(6)*(v(2)-v(4)-v(6))
           cheb24(7) = cheb12(7)+alam
           cheb24(19) = cheb12(7)-alam
           alam = x(10)*v(2)-x(6)*v(4)+x(2)*v(6)
           cheb24(11) = cheb12(11)+alam
           cheb24(15) = cheb12(11)-alam
           do 30 i=1,3
                 j = 8-i
                 v(i) = fval(i)-fval(j)
                 fval(i) = fval(i)+fval(j)
30         continue
           cheb12(5) = v(1)+x(8)*v(3)
           cheb12(9) = fval(1)-x(8)*fval(3)
           alam = x(4)*v(2)
           cheb24(5) = cheb12(5)+alam
           cheb24(21) = cheb12(5)-alam
           alam = x(8)*fval(2)-fval(4)
           cheb24(9) = cheb12(9)+alam
           cheb24(17) = cheb12(9)-alam
           cheb12(1) = fval(1)+fval(3)
           alam = fval(2)+fval(4)
           cheb24(1) = cheb12(1)+alam
           cheb24(25) = cheb12(1)-alam
           cheb12(13) = v(1)-v(3)
           cheb24(13) = cheb12(13)
           alam = 0.1e+01_dp/0.6e+01_dp
           do 40 i=2,12
                   cheb12(i) = cheb12(i)*alam
   40      continue
           alam = 0.5e+00_dp*alam
           cheb12(1) = cheb12(1)*alam
           cheb12(13) = cheb12(13)*alam
           do 50 i=2,24
                 cheb24(i) = cheb24(i)*alam
   50      continue
           cheb24(1) = 0.5e+00_dp*alam*cheb24(1)
           cheb24(25) = 0.5e+00_dp*alam*cheb24(25)
     end subroutine dqcheb

     subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax)
!DIR$ ATTRIBUTES CODE_ALIGN:32 :: dqpsrt
           integer(kind=int4),     intent(out)              :: limit
           integer(kind=int4),     intent(out)              :: last
           integer(kind=int4),     intent(out)              :: maxerr
           real(kind=dp),          intent(out)              :: ermax
           real(kind=dp),      dimension(last), intent(out) :: elist
           integer(kind=int4), dimension(last), intent(out) :: iord
           integer(kind=int4),     intent(out)              :: nrmax
           ! LOcals
           real(kind=dp), automatic :: errmax,errmin
           integer(kind=int4), automatic :: i,ibeg,ido,isucc.j,jbnd,jupbn,k
           ! Exec cdoe .....
           if(last.gt.2) go to 10
           iord(1) = 1
           iord(2) = 2
           go to 90
!c
!c           this part of the routine is only executed if, due to a
!c           difficult integrand, subdivision increased the error
!c           estimate. in the normal case the insert procedure should
!c           start after the nrmax-th largest error estimate.
!c
   10      errmax = elist(maxerr)
           if(nrmax.eq.1) go to 30
           ido = nrmax-1
           do 20 i = 1,ido
                  isucc = iord(nrmax-1)
!c ***jump out of do-loop
           if(errmax.le.elist(isucc)) go to 30
           iord(nrmax) = isucc
           nrmax = nrmax-1
   20      continue
!c
!c           compute the number of elements in the list to be maintained
!c           in descending order. this number depends on the number of
!c           subdivisions still allowed.
!c
   30      jupbn = last
           if(last.gt.(limit/2+2)) jupbn = limit+3-last
           errmin = elist(last)
!c
!c           insert errmax by traversing the list top-down,
!c           starting comparison from the element elist(iord(nrmax+1)).
!c
           jbnd = jupbn-1
           ibeg = nrmax+1
           if(ibeg.gt.jbnd) go to 50
           do 40 i=ibeg,jbnd
                 isucc = iord(i)
!c ***jump out of do-loop
                 if(errmax.ge.elist(isucc)) go to 60
                 iord(i-1) = isucc
   40      continue
   50      iord(jbnd) = maxerr
           iord(jupbn) = last
           go to 90
!c
!c           insert errmin by traversing the list bottom-up.
!c
   60      iord(i-1) = maxerr
           k = jbnd
           do 70 j=i,jbnd
                 isucc = iord(k)
!c ***jump out of do-loop
                 if(errmin.lt.elist(isucc)) go to 80
                 iord(k+1) = isucc
                 k = k-1
   70      continue
           iord(i) = last
           go to 90
   80      iord(k+1) = last
!c
!c           set maxerr and ermax.
!c
   90      maxerr = iord(nrmax)
           ermax = elist(maxerr)
     end subroutine dqpsrt

     subroutine dqelg(n,epstab,result,abserr,res3la,nres)
!DIR$ ATTRIBUTES CODE_ALIGN:32 :: dqelg
           use mod_machine_prec, only : d1mach
           integer(kind=int4),     intent(in) :: n
           !DIR$ ASSUME_ALIGNED epstab:32
           real(kind=dp), dimension(52), intent(inout) :: epstab
           real(kind=dp),                intent(inout) :: result
           real(kind=dp),                intent(out)   :: abserr
           real(kind=dp), dimension(3),  intent(inout) :: res3la
           integer(kind=int4),           intent(inout) :: nres
            ! Locals
           real(kind=dp), automatic :: delta1,delta2,delta3,d1mach,epmach,epsinf,error,err1,err2, &
            err3,e0,e1,e1abs,e2,e3,oflow,res,ss,tol1,tol2,tol3
           integer(kind=int4), automatic :: i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,neweln,num
           ! Exec code ...
           epmach = d1mach(4)
           oflow = d1mach(2)
           nres = nres+1
           abserr = oflow
           res = epstab(n)
           if(n.lt.3) go to 100
           limexp = 50
           epstab(n+2) = epstab(n)
           newelm = (n-1)/2
           epstab(n) = oflow
           num = n
           k1 = n
           do 40 i = 1,newelm
                  k2 = k1-1
                  k3 = k1-2
                  res = epstab(k1+2)
                  e0 = epstab(k3)
                  e1 = epstab(k2)
                  e2 = res
                  e1abs = ABS(e1)
                  delta2 = e2-e1
                  err2 = ABS(delta2)
                  tol2 = MAX(DABS(e2),e1abs)*epmach
                  delta3 = e1-e0
                  err3 = ABS(delta3)
                  tol3 = MAX(e1abs,ABS(e0))*epmach
                  if(err2.gt.tol2.or.err3.gt.tol3) go to 10
!c
!c           if e0, e1 and e2 are equal to within machine
!c           accuracy, convergence is assumed.
!c           result = e2
!c           abserr = abs(e1-e0)+abs(e2-e1)
!c
                  result = res
                  abserr = err2+err3
!c ***jump out of do-loop
                  go to 100
   10             e3 = epstab(k1)
                  epstab(k1) = e1
                  delta1 = e1-e3
                  err1 = ABS(delta1)
                  tol1 = MAX(e1abs,ABS(e3))*epmach
!c
!c           if two elements are very close to each other, omit
!c           a part of the table by adjusting the value of n
!c
                  if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20
                  ss = 0.1e+01_dp/delta1+0.1e+01_dp/delta2-0.1e+01_dp/delta3
                  epsinf = ABS(ss*e1)
!c
!c           test to detect irregular behaviour in the table, and
!c           eventually omit a part of the table adjusting the value
!c           of n.
!c
                 if(epsinf.gt.0.1e-03_dp) go to 30
   20            n = i+i-1
!c ***jump out of do-loop
                 go to 50
!c
!c           compute a new element and eventually adjust
!c           the value of result.
!c
   30           res = e1+0.1e+01_dp/ss
                epstab(k1) = res
                k1 = k1-2
                error = err2+ABS(res-e2)+err3
                if(error.gt.abserr) go to 40
                abserr = error
                result = res
   40      continue
!c
!c           shift the table.
!c
   50       if(n.eq.limexp) n = 2*(limexp/2)-1
            ib = 1
            if((num/2)*2.eq.num) ib = 2
            ie = newelm+1
            do 60 i=1,ie
                  ib2 = ib+2
                  epstab(ib) = epstab(ib2)
                  ib = ib2
   60      continue
           if(num.eq.n) go to 80
           indx = num-n+1
           do 70 i = 1,n
                 epstab(i)= epstab(indx)
                 indx = indx+1
   70      continue
   80      if(nres.ge.4) go to 90
           res3la(nres) = result
           abserr = oflow
           go to 100
!c
!c           compute error estimate
!c
   90      abserr = ABS(result-res3la(3))+ABS(result-res3la(2)) &
           + ABS(result-res3la(1))
           res3la(1) = res3la(2)
           res3la(2) = res3la(3)
           res3la(3) = result
  100      abserr = MAX(abserr,0.5e+01_dp*epmach*ABS(result))
     end subroutine dqelg

end module mod_quadratures