!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Makes invariants for the strain tensor and computes the main strain.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nn  polynomial  degree
!> @param[in] duxdx nodal values for spatial derivatives of the displacement
!> @param[in] duydx nodal values for spatial derivatives of the displacement
!> @param[in] duzdx nodal values for spatial derivatives of the displacement
!> @param[in] duxdy nodal values for spatial derivatives of the displacement
!> @param[in] duydy nodal values for spatial derivatives of the displacement
!> @param[in] duzdy nodal values for spatial derivatives of the displacement
!> @param[in] duxdz nodal values for spatial derivatives of the displacement
!> @param[in] duydz nodal values for spatial derivatives of the displacement
!> @param[in] duzdz nodal values for spatial derivatives of the displacement
!> @param[in] yon 1 if the point is non-linear elastic, 0 otherwise
!> @param[out] R averaged main shear strain

      subroutine MAKE_INVARIANTS_AND_MAIN_STRAIN(nn,&
                                                duxdx,duydx,duzdx,&
                                                duxdy,duydy,duzdy,&
                                                duxdz,duydz,duzdz,&
                                                R,yon)

      implicit none

      integer*4 :: nn
      integer*4 :: i,j,k

      integer*4, dimension(nn,nn,nn) :: yon

      real*8 :: exx,eyy,ezz,exy,eyz,ezx
      real*8 :: R1,R2,R3
      real*8 :: invar1,invar2,invar3
      real*8 :: strain_I,strain_II,strain_III
      real*8 :: R_average_elem

      real*8, dimension(nn,nn,nn) :: duxdx,duxdy,duxdz,duydx,duydy,duydz,duzdx,duzdy,duzdz
      real*8, dimension(nn,nn,nn) :: R

      R_average_elem = 0.0d0

      do i = 1,nn
         do j = 1,nn
            do k = 1,nn

                if (yon(i,j,k).eq.1) then

                        !+-----------------------------------------
                        !! Invariants of the strain tensor sigma_ij

                        exx = duxdx(i,j,k)
                        eyy = duydy(i,j,k)
                        ezz = duzdz(i,j,k)

                        exy = .5 * (duxdy(i,j,k) + duydx(i,j,k))
                        eyz = .5 * (duydz(i,j,k) + duzdy(i,j,k))
                        ezx = .5 * (duzdx(i,j,k) + duxdz(i,j,k))

                        invar1 = exx + eyy + ezz

                        invar2 = exx * eyy + &
                                 eyy * ezz + &
                                 ezz* exx - &
                                 exy**2 - &
                                 eyz**2 - &
                                 ezx**2

                        invar3 = exx * eyy * ezz + &
                                 2 * exy * eyz * (-ezx) - &
                                 exx * eyz**2 - &
                                 eyy * ezx**2 - &
                                 ezz * exy**2

                        !+-----------------------------------------
                        !! Principal strain computations

                        call CUBIC(-invar1,invar2,-invar3,&
                                  strain_I,strain_II,strain_III)

                        !call ZerosPolyO3(-invar1,invar2,-invar3,&
                        !          strain_I,strain_II,strain_III)

                        !+-----------------------------------------
                        !! Max shear strain computation

                        R(i,j,k) = (max(strain_I,strain_II,strain_III) - &
                                        min(strain_I,strain_II,strain_III) ) / 2

                        R_average_elem = R_average_elem + R(i,j,k)

                        !!
                        !+-----------------------------------------

                endif !if (yon(i,j,k).eq.1) then

            enddo
         enddo
      enddo

      R_average_elem = R_average_elem / (nn*nn*nn)

      do i = 1,nn
        do j = 1,nn
           do k = 1,nn

                R(i,j,k) = R_average_elem

           enddo
        enddo
      enddo

      return

      end subroutine MAKE_INVARIANTS_AND_MAIN_STRAIN


      subroutine nvkt03(a,ia,c,ic,g,v,w,ipvt,dnorma,n,m,mi1,mi,nmd,ndf)
C     SUBROUTINE NVKT03(A,IA,C,IC,G,V,W,IPVT,DNORMA,N,M,MI1,MI,NMD,NDF)
C
C***********************************************************************
C                                                                      *
C                                                                      *
C      Copyright:       Eduardo Casas Renteria                         *
C                       Cecilia Pola Mendez                            *
C                                                                      *
C       Departamento de Matematicas,Estadistica y Computacion          *
C       -----------------------------------------------------          *
C                       UNIVERSIDAD DE CANTABRIA                       *
C                       ------------------------                       *
C                              AGOSTO  1987                            *
C                                                                      *
C***********************************************************************
C
C     OBJETIVO:
C        Esta es una subrutina auxiliar a  OPTR03. Calcula la norma del
C        vector de Kuhn-Tucker.
C
C     LISTA DE LLAMADA:
C
C        A      Matriz de dimension (IA,NDF-NMD). (Referencia en OPTR03)
C
C        C      Matriz  de  dimension   (IC,MI+NMD-N).  ( Referencia  en
C               OPTR03).
C
C        G      Vector de dimension  N que contiene el vector gradiente.
C
C        V      Vector  de  dimension  M  que contiene  el vector de los
C               multiplicadores de Lagrange.
C
C        W      Vector de trabajo de dimension  N+M.
C
C        IPVT   Vector de dimension  M. (Referencia en  OPTR03).
C
C        DNORMA Variable de salida que contiene la norma del vector de
C               Kuhn-Tucker.
C
C        MI1    (Referencia en OPTR03).
C
C        MI     (Referencia en  OPTR03).
C
C        NMD    N+MD (Referencia en OPTR03).
C
C        NDF    NMD+MIF+MDF+1 (Referencia en OPTR03).
C
C
C        Esta subrutina trabaja en doble precision via una sentencia
C     "implicit":
C                Implicit double precision (a-h,o-z)
C
C     SUBPROGRAMAS AUXILIARES:  ddot,dadd,dnrm2
C     FUNCIONES FORTRAN INTRINSECAS:  abs,mod,sqrt
C
      implicit double precision(a-h,o-z)
      dimension a(ia,*),c(ic,*),v(*),w(*),ipvt(*),g(*)
      m1=m+1
      mi2=mi1+1
      ni=mi-n
      do 30 i=1,n
         do 10 j=1,mi1
10       w(j)=c(i,ipvt(j))
         do 20 j=mi2,m
            ij=ipvt(j)
            if(ij.lt.0) then
               if(i.eq.-ij) then
                  w(j)=-1
               else
                  w(j)=0
               end if
            else if(ij.le.n) then
               if(i.eq.ij) then
                  w(j)=1
               else
                  w(j)=0
               end if
            else if(ij.le.nmd) then
               w(j)=c(i,ij+ni)
            else if(ij.lt.ndf) then
               w(j)=a(i,ij-nmd)
            end if
20       continue
         w(m+i)=ddot(m,w,1,v,1)
30    continue
      call dadd(n,g,1,w(m1),1)
      dnorma=dnrm2(n,w(m1),1)
      end


*DECK ATANH
      FUNCTION ATANH (X)
C***BEGIN PROLOGUE  ATANH
C***PURPOSE  Compute the arc hyperbolic tangent.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C)
C***KEYWORDS  ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS,
C             FNLIB, INVERSE HYPERBOLIC TANGENT
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ATANH(X) computes the arc hyperbolic tangent of X.
C
C Series for ATNH       on the interval  0.          to  2.50000D-01
C                                        with weighted error   6.70E-18
C                                         log weighted error  17.17
C                               significant figures required  16.01
C                                    decimal places required  17.76
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  ATANH
      DIMENSION ATNHCS(15)
      LOGICAL FIRST
      SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST
      DATA ATNHCS( 1) /    .0943951023 93195492E0 /
      DATA ATNHCS( 2) /    .0491984370 55786159E0 /
      DATA ATNHCS( 3) /    .0021025935 22455432E0 /
      DATA ATNHCS( 4) /    .0001073554 44977611E0 /
      DATA ATNHCS( 5) /    .0000059782 67249293E0 /
      DATA ATNHCS( 6) /    .0000003505 06203088E0 /
      DATA ATNHCS( 7) /    .0000000212 63743437E0 /
      DATA ATNHCS( 8) /    .0000000013 21694535E0 /
      DATA ATNHCS( 9) /    .0000000000 83658755E0 /
      DATA ATNHCS(10) /    .0000000000 05370503E0 /
      DATA ATNHCS(11) /    .0000000000 00348665E0 /
      DATA ATNHCS(12) /    .0000000000 00022845E0 /
      DATA ATNHCS(13) /    .0000000000 00001508E0 /
      DATA ATNHCS(14) /    .0000000000 00000100E0 /
      DATA ATNHCS(15) /    .0000000000 00000006E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  ATANH
      IF (FIRST) THEN
         NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3))
         DXREL = SQRT (R1MACH(4))
         SQEPS = SQRT (3.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y .GE. 1.0) CALL XERMSG ('SLATEC', 'ATANH', 'ABS(X) GE 1', 2,
     +   2)
C
      IF (1.0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'ATANH',
     +   'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1)
C
      ATANH = X
      IF (Y.GT.SQEPS .AND. Y.LE.0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1.,
     1  ATNHCS, NTERMS))
      IF (Y.GT.0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X))
C
      RETURN
      END


submodule(euler_interface_m) euler_prob_0063_m

contains

    module character(len=20) function euler0063()
        write (euler0063, "(i20)") answer()
    end function euler0063

    function answer() result(ret)
        use euler_multiprecision_m
        implicit none

        integer :: ret, power, digs
        type(multiprecision_int_t) :: idx

        ret = 0
        idx = 1
        outer: do while (idx <= 9)
            power = 1
            inner: do
                digs = digits_of(idx**power)
                if (digs < power) then
                    exit inner
                else if (digs == power) then
                    ret = ret + 1
                end if
                power = power + 1
            end do inner
            idx = idx + 1
        end do outer
    end function answer

end submodule euler_prob_0063_m


SUBROUTINE K_Poten2RectLinear(eNum)
   USE PrecTypes
   USE GlobalData
   USE Gauss
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   K_Poten2RectLinear
   ! PARENT: Mat_Poten2RectLinear
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Calculate stiffness matrix a rectangular linear element for
   !         two-dimensional steady-state heat conduction problems.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER, INTENT(IN) :: eNum

   INTEGER :: i,j,k,l

   ! Variables used for integrations of rectilinear elements
   REAL(dp) :: Delta
   REAL(dp) :: x1, x2, x3, y1, y2, y3, x4, y4
   REAL(dp) :: xi_m1, xi_p1, eta_m1, eta_p1
   REAL(dp) :: xi, w_xi, eta, w_eta
   REAL(dp) :: xi4, eta4
   REAL(dp) :: N1, N2, N3, N4
   REAL(dp) :: DN1Dxi, DN1Deta, DN2Dxi, DN2Deta, DN3Dxi, DN3Deta, DN4Dxi, DN4Deta
   REAL(dp) :: DxDxi, DxDeta, DyDxi, DyDeta
   REAL(dp) :: invJ11, invJ12, invJ21, invJ22
   REAL(dp) :: DN1Dx, DN1Dy, DN2Dx, DN2Dy, DN3Dx, DN3Dy, DN4Dx, DN4Dy
   REAL(dp) :: det
   REAL(dp) :: Dm(2,2)                                      ! [D] matrix
   REAL(dp) :: Bm1(2),    Bm2(2),    Bm3(2),    Bm4(2)      ! [B] matrix
   REAL(dp) :: Dm_Bm1(2), Dm_Bm2(2), Dm_Bm3(2), Dm_Bm4(2)   ! [D][B]
   REAL(dp) :: Klocal(4,4), Klocal_eta(4,4)
   REAL(dp) :: kx, ky

   INTEGER  :: p1, p2, p3, p4

   Krect_p = 0.0_dp

   kx  = lambda( emtype(eNum), 1 )  ! thermal conductivity in x-direction
   ky  = lambda( emtype(eNum), 2 )  ! thermal conductivity in y-direction

   ! [D] matrix
   !
   !       |  -kx     0   |
   ! [D] = |              |
   !       |   0     -ky  |
   Dm(1,1) = -kx
   Dm(1,2) = 0.0_dp
   Dm(2,1) = 0.0_dp
   Dm(2,2) = -ky

   Bm1 = 0.0
   Bm2 = 0.0
   Bm3 = 0.0
   Bm4 = 0.0

   ! Global node numbers of the element under consideration
   p1 = elm(eNum,1)
   p2 = elm(eNum,2)
   p3 = elm(eNum,3)
   p4 = elm(eNum,4)

   ! Coordinates of node 1
   x1 = x( p1 )
   y1 = y( p1 )

   ! Coordinates of node 2
   x2 = x( p2 )
   y2 = y( p2 )

   ! Coordinates of node 3
   x3 = x( p3 )
   y3 = y( p3 )

   ! Coordinates of node 4
   x4 = x( p4 )
   y4 = y( p4 )

   DO i=1, gausspoint

      xi   = zt(i)
      w_xi = wt(i)

      xi4  = 0.25_dp * xi    !  xi/4

      KlocaL = 0.0_dp        !  initialize the array for storing the integrated results for j-loop

      DO j=1, gausspoint

         Klocal_eta = 0.0_dp

         eta   = zt(j)
         w_eta = wt(j)

         eta4 = 0.25_dp * eta    ! eta/4

         DN1Dxi  = -0.25_dp + eta4
         DN1Deta = -0.25_dp + xi4
         DN2Dxi  =  0.25_dp - eta4
         DN2Deta = -0.25_dp - xi4
         DN3Dxi  =  0.25_dp + eta4
         DN3Deta =  0.25_dp + xi4
         DN4Dxi  = -0.25_dp - eta4
         DN4Deta =  0.25_dp - xi4

         DxDxi  = DN1Dxi  * x1 + DN2Dxi  * x2 + DN3Dxi  * x3 + DN4Dxi  * x4
         DxDeta = DN1Deta * x1 + DN2Deta * x2 + DN3Deta * x3 + DN4Deta * x4
         DyDxi  = DN1Dxi  * y1 + DN2Dxi  * y2 + DN3Dxi  * y3 + DN4Dxi  * y4
         DyDeta = DN1Deta * y1 + DN2Deta * y2 + DN3Deta * y3 + DN4Deta * y4

         det = DxDxi * DyDeta - DyDxi * DxDeta
         Delta = ABS(det)

         invJ11 =  DyDeta
         invJ12 = -DyDxi
         invJ21 = -DxDeta
         invJ22 =  DxDxi
         DN1Dx = (invJ11 * DN1Dxi + invJ12 * DN1Deta)/det       !   ∂N1/∂x
         DN1Dy = (invJ21 * DN1Dxi + invJ22 * DN1Deta)/det       !   ∂N1/∂y
         DN2Dx = (invJ11 * DN2Dxi + invJ12 * DN2Deta)/det       !   ∂N2/∂x
         DN2Dy = (invJ21 * DN2Dxi + invJ22 * DN2Deta)/det       !   ∂N2/∂y
         DN3Dx = (invJ11 * DN3Dxi + invJ12 * DN3Deta)/det       !   ∂N3/∂x
         DN3Dy = (invJ21 * DN3Dxi + invJ22 * DN3Deta)/det       !   ∂N3/∂y
         DN4Dx = (invJ11 * DN4Dxi + invJ12 * DN4Deta)/det       !   ∂N4/∂x
         DN4Dy = (invJ21 * DN4Dxi + invJ22 * DN4Deta)/det       !   ∂N4/∂y

         !         |  ∂N1/∂x  |
         ! [B1] =  |          |
         !         |  ∂N1/∂y  |
         Bm1(1) = DN1Dx
         Bm1(2) = DN1Dy

         !         |  ∂N2/∂x  |
         ! [B2] =  |          |
         !         |  ∂N2/∂y  |
         Bm2(1) = DN2Dx
         Bm2(2) = DN2Dy

         !         |  ∂N3/∂x  |
         ! [B3] =  |          |
         !         |  ∂N3/∂y  |
         Bm3(1) = DN3Dx
         Bm3(2) = DN3Dy

         !         |  ∂N4/∂x  |
         ! [B4] =  |          |
         !         |  ∂N4/∂y  |
         Bm4(1) = DN4Dx
         Bm4(2) = DN4Dy

         Dm_Bm1(1) = Dm(1,1) * Bm1(1) + Dm(1,2) * Bm1(2)
         Dm_Bm1(2) = Dm(2,1) * Bm1(1) + Dm(2,2) * Bm1(2)

         Dm_Bm2(1) = Dm(1,1) * Bm2(1) + Dm(1,2) * Bm2(2)
         Dm_Bm2(2) = Dm(2,1) * Bm2(1) + Dm(2,2) * Bm2(2)

         Dm_Bm3(1) = Dm(1,1) * Bm3(1) + Dm(1,2) * Bm3(2)
         Dm_Bm3(2) = Dm(2,1) * Bm3(1) + Dm(2,2) * Bm3(2)

         Dm_Bm4(1) = Dm(1,1) * Bm4(1) + Dm(1,2) * Bm4(2)
         Dm_Bm4(2) = Dm(2,1) * Bm4(1) + Dm(2,2) * Bm4(2)

         ! [K11] = [B1]^T [D] [B1]
         ! [K12] = [B1]^T [D] [B2]
         ! [K13] = [B1]^T [D] [B3]
         ! [K14] = [B1]^T [D] [B4]
         Klocal_eta(1,1) = ( Bm1(1) * Dm_Bm1(1) + Bm1(2) * Dm_Bm1(2) ) * Delta
         Klocal_eta(1,2) = ( Bm1(1) * Dm_Bm2(1) + Bm1(2) * Dm_Bm2(2) ) * Delta
         Klocal_eta(1,3) = ( Bm1(1) * Dm_Bm3(1) + Bm1(2) * Dm_Bm3(2) ) * Delta
         Klocal_eta(1,4) = ( Bm1(1) * Dm_Bm4(1) + Bm1(2) * Dm_Bm4(2) ) * Delta

         ! [K21] = [B2]^T [D] [B1]
         ! [K22] = [B2]^T [D] [B2]
         ! [K23] = [B2]^T [D] [B3]
         ! [K24] = [B2]^T [D] [B4]
         Klocal_eta(2,1) = ( Bm2(1) * Dm_Bm1(1) + Bm2(2) * Dm_Bm1(2) ) * Delta
         Klocal_eta(2,2) = ( Bm2(1) * Dm_Bm2(1) + Bm2(2) * Dm_Bm2(2) ) * Delta
         Klocal_eta(2,3) = ( Bm2(1) * Dm_Bm3(1) + Bm2(2) * Dm_Bm3(2) ) * Delta
         Klocal_eta(2,4) = ( Bm2(1) * Dm_Bm4(1) + Bm2(2) * Dm_Bm4(2) ) * Delta

         ! [K31] = [B3]^T [D] [B1]
         ! [K32] = [B3]^T [D] [B2]
         ! [K33] = [B3]^T [D] [B3]
         ! [K34] = [B3]^T [D] [B4]
         Klocal_eta(3,1) = ( Bm3(1) * Dm_Bm1(1) + Bm3(2) * Dm_Bm1(2) ) * Delta
         Klocal_eta(3,2) = ( Bm3(1) * Dm_Bm2(1) + Bm3(2) * Dm_Bm2(2) ) * Delta
         Klocal_eta(3,3) = ( Bm3(1) * Dm_Bm3(1) + Bm3(2) * Dm_Bm3(2) ) * Delta
         Klocal_eta(3,4) = ( Bm3(1) * Dm_Bm4(1) + Bm3(2) * Dm_Bm4(2) ) * Delta

         ! [K31] = [B3]^T [D] [B1]
         ! [K32] = [B3]^T [D] [B2]
         ! [K33] = [B3]^T [D] [B3]
         ! [K34] = [B3]^T [D] [B4]
         Klocal_eta(4,1) = ( Bm4(1) * Dm_Bm1(1) + Bm4(2) * Dm_Bm1(2) ) * Delta
         Klocal_eta(4,2) = ( Bm4(1) * Dm_Bm2(1) + Bm4(2) * Dm_Bm2(2) ) * Delta
         Klocal_eta(4,3) = ( Bm4(1) * Dm_Bm3(1) + Bm4(2) * Dm_Bm3(2) ) * Delta
         Klocal_eta(4,4) = ( Bm4(1) * Dm_Bm4(1) + Bm4(2) * Dm_Bm4(2) ) * Delta

         Klocal_eta =  Klocal_eta * w_eta

         Klocal = Klocal + Klocal_eta

      END DO  ! end of loop for eta

      Krect_p = Krect_p + Klocal * w_xi

   END DO   ! end of loop for xi

   Krect_p = Krect_p * thickness(eNum)

   RETURN
END SUBROUTINE K_Poten2RectLinear


      subroutine gen2m(r,p,wt2,*)
C---generate two particle phase space and x1,x2 integration
C---p1+p2 --> p3+p4
      implicit none
      include 'constants.f'
      include 'limits.f'
      include 'mxdim.f'
      include 'hdecaymode.f'
      include 'masses.f'
      include 'breit.f'
      include 'x1x2.f'
      integer j,nu

      double precision r(mxdim),p(mxpart,4),mass
      double precision ymax,yave,ydif,xjac,y3,y4,phi,wt0,wt2,w3,vs
      double precision vsqmin,vsqmax,pt,s34,xmin,rtshat,udif,trmass,beta
      include 'energy.f'
      parameter(wt0=1d0/16d0/pi)

      do j=1,mxpart
      do nu=1,4
      p(j,nu)=0d0
      enddo
      enddo

      wt2=0d0

      if (n3 .eq. 1) then
c--- generate s34 according to a Breit-Wigner, for gg->H
        call breitw(r(3),wsqmin,wsqmax,mass3,width3,s34,w3)
        xmin=0d0
      if     (hdecaymode .eq. 'bqba') then
        mass=mb
      elseif (hdecaymode .eq. 'tlta') then
        mass=mtau
      else
        write(6,*) 'Unanticipated hdecaymode in gen2m: ',hdecaymode
        stop
      endif
      else
c--- no resonance, for tt~,bb~,cc~
      mass=mass2
        vsqmax=1d0/(4d0*mass**2)
        vsqmin=1d0/sqrts**2
        xmin=vsqmin/vsqmax
        vs=(vsqmax-vsqmin)*r(3)+vsqmin
        s34=1/vs
        w3=(vsqmax-vsqmin)*s34**2
      endif

      rtshat=dsqrt(s34)
      ymax=dlog(sqrts/rtshat)
      yave=ymax*(two*r(1)-1d0)
c----udif=tanh(ydif)
      beta=dsqrt(1d0-4d0*mass**2/s34)
      udif=beta*(two*r(2)-1d0)
      ydif=half*dlog((1d0+udif)/(1d0-udif))
      xjac=four*ymax*beta

      y3=yave+ydif
      y4=yave-ydif

      xjac=xjac*w3
      phi=2d0*pi*r(4)

      xx(1)=rtshat/sqrts*exp(+yave)
      xx(2)=rtshat/sqrts*exp(-yave)
      trmass=rtshat/(2d0*dcosh(ydif))

      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)) then
        write(6,*) 'problems with xx(1),xx(2) in gen2',xx(1),xx(2)
        return 1
      endif

      pt=dsqrt(trmass**2-mass**2)

      p(1,4)=-0.5d0*xx(1)*sqrts
      p(1,1)=0d0
      p(1,2)=0d0
      p(1,3)=-0.5d0*xx(1)*sqrts

      p(2,4)=-0.5d0*xx(2)*sqrts
      p(2,1)=0d0
      p(2,2)=0d0
      p(2,3)=+0.5d0*xx(2)*sqrts

      p(3,4)=+trmass*dcosh(y3)
      p(3,1)=+pt*dsin(phi)
      p(3,2)=+pt*dcos(phi)
      p(3,3)=+trmass*dsinh(y3)

      p(4,4)=+trmass*dcosh(y4)
      p(4,1)=-pt*dsin(phi)
      p(4,2)=-pt*dcos(phi)
      p(4,3)=+trmass*dsinh(y4)

      wt2=wt0*xjac/sqrts**2

c      write(6,*) 's34',s34
c      write(6,*) 's34-4d0*mass**2',s34-4d0*mass**2
c      write(6,*) 'wsqmax',wsqmax
c      write(6,*) 'ymax',ymax
c      write(6,*) 'wsqmin',wsqmin
c      write(6,*) 'y3',y3
c      write(6,*) 'y4',y4
c      write(6,*) 'xx(1)',xx(1)
c      write(6,*) 'xx(2)',xx(2)
c      write(6,*) 'trmass',trmass
c      write(6,*) 'mass',mass
c      write(6,*) 'pt',pt
c      write(6,*) 's12',2d0*(p(1,4)*p(2,4)-p(1,3)*p(2,3))

      return

      end


      SUBROUTINE MB04WD( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2,
     $                   CS, TAU, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To generate a matrix Q with orthogonal columns (spanning an
C     isotropic subspace), which is defined as the first n columns
C     of a product of symplectic reflectors and Givens rotations,
C
C         Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
C             diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
C                               ....
C             diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).
C
C     The matrix Q is returned in terms of its first 2*M rows
C
C                      [  op( Q1 )   op( Q2 ) ]
C                  Q = [                      ].
C                      [ -op( Q2 )   op( Q1 ) ]
C
C     Blocked version of the SLICOT Library routine MB04WU.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANQ1  CHARACTER*1
C             Specifies the form of op( Q1 ) as follows:
C             = 'N':  op( Q1 ) = Q1;
C             = 'T':  op( Q1 ) = Q1';
C             = 'C':  op( Q1 ) = Q1'.
C
C     TRANQ2  CHARACTER*1
C             Specifies the form of op( Q2 ) as follows:
C             = 'N':  op( Q2 ) = Q2;
C             = 'T':  op( Q2 ) = Q2';
C             = 'C':  op( Q2 ) = Q2'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices Q1 and Q2. M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices Q1 and Q2.
C             M >= N >= 0.
C
C     K       (input) INTEGER
C             The number of symplectic Givens rotations whose product
C             partly defines the matrix Q. N >= K >= 0.
C
C     Q1      (input/output) DOUBLE PRECISION array, dimension
C                     (LDQ1,N) if TRANQ1 = 'N',
C                     (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C'
C             On entry with TRANQ1 = 'N', the leading M-by-K part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector F(i).
C             On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
C             K-by-M part of this array must contain in its i-th row
C             the vector which defines the elementary reflector F(i).
C             On exit with TRANQ1 = 'N', the leading M-by-N part of this
C             array contains the matrix Q1.
C             On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
C             N-by-M part of this array contains the matrix Q1'.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.
C             LDQ1 >= MAX(1,M),  if TRANQ1 = 'N';
C             LDQ1 >= MAX(1,N),  if TRANQ1 = 'T' or TRANQ1 = 'C'.
C
C     Q2      (input/output) DOUBLE PRECISION array, dimension
C                     (LDQ2,N) if TRANQ2 = 'N',
C                     (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C'
C             On entry with TRANQ2 = 'N', the leading M-by-K part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector H(i) and, on the
C             diagonal, the scalar factor of H(i).
C             On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
C             K-by-M part of this array must contain in its i-th row the
C             vector which defines the elementary reflector H(i) and, on
C             the diagonal, the scalar factor of H(i).
C             On exit with TRANQ2 = 'N', the leading M-by-N part of this
C             array contains the matrix Q2.
C             On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
C             N-by-M part of this array contains the matrix Q2'.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.
C             LDQ2 >= MAX(1,M),  if TRANQ2 = 'N';
C             LDQ2 >= MAX(1,N),  if TRANQ2 = 'T' or TRANQ2 = 'C'.
C
C     CS      (input) DOUBLE PRECISION array, dimension (2*K)
C             On entry, the first 2*K elements of this array must
C             contain the cosines and sines of the symplectic Givens
C             rotations G(i).
C
C     TAU     (input) DOUBLE PRECISION array, dimension (K)
C             On entry, the first K elements of this array must
C             contain the scalar factors of the elementary reflectors
C             F(i).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK, MAX(M+N,8*N*NB + 15*NB*NB), where NB is
C             the optimal block size determined by the function UE01MD.
C             On exit, if  INFO = -13,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,M+N).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     REFERENCES
C
C     [1] Kressner, D.
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSB).
C     V. Sima, Aug. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANQ1, TRANQ2
      INTEGER           INFO, K, LDQ1, LDQ2, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           LQUERY, LTRQ1, LTRQ2
      INTEGER           I, IB, IERR, KI, KK, MINWRK, NB, NBMIN, NX,
     $                  PDRS, PDT, PDW, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           UE01MD
      EXTERNAL          LSAME, UE01MD
C     .. External Subroutines ..
      EXTERNAL          DORGQR, MB04QC, MB04QF, MB04WU, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN, SQRT
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      LTRQ1 = LSAME( TRANQ1, 'T' ) .OR. LSAME( TRANQ1,'C' )
      LTRQ2 = LSAME( TRANQ2, 'T' ) .OR. LSAME( TRANQ2,'C' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( M.LT.0 ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -4
      ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -5
      ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR.
     $     ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR.
     $     ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN
         INFO = -9
      ELSE
         LQUERY = LDWORK.EQ.-1
         MINWRK = MAX( 1, M + N )
         IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            DWORK(1) = DBLE( MINWRK )
            INFO = -13
         ELSE
            IF ( MIN( M, N ).EQ.0 ) THEN
               WRKOPT = ONE
            ELSE
               CALL DORGQR( M, N, K, DWORK, M, DWORK, DWORK, -1, INFO )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
               NB     = INT( WRKOPT/N )
               WRKOPT = MAX( WRKOPT, 8*N*NB + 15*NB*NB )
            END IF
            IF ( LQUERY ) THEN
               DWORK(1) = DBLE( WRKOPT )
               RETURN
            END IF
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04WD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      NBMIN = 2
      NX = 0
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, UE01MD( 3, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) )
         IF ( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            IF( LDWORK.LT.WRKOPT ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = INT( ( SQRT( DBLE( 16*N*N + 15*LDWORK ) )
     $                     - DBLE( 4*N ) ) / 15.0D0 )
               NBMIN = MAX( 2, UE01MD( 2, 'MB04WD', TRANQ1 // TRANQ2, M,
     $                                 N, K ) )
            END IF
         END IF
      END IF
C
      IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code after the last block.
C        The first kk columns are handled by the block method.
C
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
      ELSE
         KK = 0
      END IF
C
C     Use unblocked code for the last or only block.
C
      IF ( KK.LT.N )
     $   CALL MB04WU( TRANQ1, TRANQ2, M-KK, N-KK, K-KK, Q1(KK+1,KK+1),
     $                LDQ1, Q2(KK+1,KK+1), LDQ2, CS(2*KK+1), TAU(KK+1),
     $                DWORK, LDWORK, IERR )
C
C     Blocked code.
C
      IF ( KK.GT.0 ) THEN
         PDRS = 1
         PDT  = PDRS + 6*NB*NB
         PDW  = PDT  + 9*NB*NB
         IF ( LTRQ1.AND.LTRQ2 ) THEN
            DO 10 I = KI + 1, 1, -NB
               IB = MIN( NB, K-I+1 )
               IF ( I+IB.LE.N ) THEN
C
C                 Form the triangular factors of the symplectic block
C                 reflector SH.
C
                  CALL MB04QF( 'Forward', 'Rowwise', 'Rowwise', M-I+1,
     $                         IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2,
     $                         CS(2*I-1), TAU(I), DWORK(PDRS), NB,
     $                         DWORK(PDT), NB, DWORK(PDW) )
C
C                 Apply SH to Q1(i+ib:n,i:m) and Q2(i+ib:n,i:m) from
C                 the right.
C
                  CALL MB04QC( 'Zero Structure', 'Transpose',
     $                         'Transpose', 'No Transpose', 'Forward',
     $                         'Rowwise', 'Rowwise', M-I+1, N-I-IB+1,
     $                         IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2,
     $                         DWORK(PDRS), NB, DWORK(PDT), NB,
     $                         Q2(I+IB,I), LDQ2, Q1(I+IB,I), LDQ1,
     $                         DWORK(PDW) )
               END IF
C
C              Apply SH to columns i:m of the current block.
C
               CALL MB04WU( 'Transpose', 'Transpose', M-I+1, IB, IB,
     $                      Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1),
     $                      TAU(I), DWORK, LDWORK, IERR )
   10       CONTINUE
C
         ELSE IF ( LTRQ1 ) THEN
            DO 20 I = KI + 1, 1, -NB
               IB = MIN( NB, K-I+1 )
               IF ( I+IB.LE.N ) THEN
C
C                 Form the triangular factors of the symplectic block
C                 reflector SH.
C
                  CALL MB04QF( 'Forward', 'Rowwise', 'Columnwise',
     $                         M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2,
     $                         CS(2*I-1), TAU(I), DWORK(PDRS), NB,
     $                         DWORK(PDT), NB, DWORK(PDW) )
C
C                 Apply SH to Q1(i+ib:n,i:m) from the right and to
C                 Q2(i:m,i+ib:n) from the left.
C
                  CALL MB04QC( 'Zero Structure', 'No Transpose',
     $                         'Transpose', 'No Transpose',
     $                         'Forward', 'Rowwise', 'Columnwise',
     $                         M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1,
     $                         Q2(I,I), LDQ2, DWORK(PDRS), NB,
     $                         DWORK(PDT), NB, Q2(I,I+IB), LDQ2,
     $                         Q1(I+IB,I), LDQ1, DWORK(PDW) )
               END IF
C
C              Apply SH to columns/rows i:m of the current block.
C
               CALL MB04WU( 'Transpose', 'No Transpose', M-I+1, IB, IB,
     $                      Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1),
     $                      TAU(I), DWORK, LDWORK, IERR )
   20       CONTINUE
C
         ELSE IF ( LTRQ2 ) THEN
            DO 30 I = KI + 1, 1, -NB
               IB = MIN( NB, K-I+1 )
               IF ( I+IB.LE.N ) THEN
C
C                 Form the triangular factors of the symplectic block
C                 reflector SH.
C
                  CALL MB04QF( 'Forward', 'Columnwise', 'Rowwise',
     $                         M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2,
     $                         CS(2*I-1), TAU(I), DWORK(PDRS), NB,
     $                         DWORK(PDT), NB, DWORK(PDW) )
C
C                 Apply SH to Q1(i:m,i+ib:n) from the left and to
C                 Q2(i+ib:n,i:m) from the right.
C
                  CALL MB04QC( 'Zero Structure', 'Transpose',
     $                        'No Transpose', 'No Transpose', 'Forward',
     $                         'Columnwise', 'Rowwise', M-I+1, N-I-IB+1,
     $                         IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2,
     $                         DWORK(PDRS), NB, DWORK(PDT), NB,
     $                         Q2(I+IB,I), LDQ2, Q1(I,I+IB), LDQ1,
     $                         DWORK(PDW) )
               END IF
C
C              Apply SH to columns/rows i:m of the current block.
C
               CALL MB04WU( 'No Transpose', 'Transpose', M-I+1, IB, IB,
     $                      Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1),
     $                      TAU(I), DWORK, LDWORK, IERR )
   30       CONTINUE
C
         ELSE
            DO 40 I = KI + 1, 1, -NB
               IB = MIN( NB, K-I+1 )
               IF ( I+IB.LE.N ) THEN
C
C                 Form the triangular factors of the symplectic block
C                 reflector SH.
C
                  CALL MB04QF( 'Forward', 'Columnwise', 'Columnwise',
     $                         M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2,
     $                         CS(2*I-1), TAU(I), DWORK(PDRS), NB,
     $                         DWORK(PDT), NB, DWORK(PDW) )
C
C                 Apply SH to Q1(i:m,i+ib:n) and Q2(i:m,i+ib:n) from
C                 the left.
C
                  CALL MB04QC( 'Zero Structure', 'No Transpose',
     $                         'No Transpose', 'No Transpose',
     $                         'Forward', 'Columnwise', 'Columnwise',
     $                         M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1,
     $                         Q2(I,I), LDQ2, DWORK(PDRS), NB,
     $                         DWORK(PDT), NB, Q2(I,I+IB), LDQ2,
     $                         Q1(I,I+IB), LDQ1,  DWORK(PDW) )
               END IF
C
C              Apply SH to rows i:m of the current block.
C
               CALL MB04WU( 'No Transpose', 'No Transpose', M-I+1, IB,
     $                      IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1),
     $                      TAU(I), DWORK, LDWORK, IERR )
   40       CONTINUE
         END IF
      END IF
C
      DWORK(1) = DBLE( WRKOPT )
C
      RETURN
C *** Last line of MB04WD ***
      END


      function densrpsi(r,psi)
      parameter (pi=3.1415926535, sq8=2.828427125)

      common /potconstants/ apot(20,0:20000), fr(20,0:20000),
     +     dr, nr, lmax, potcor
      common /gparameters/  a, b, c, v0, q, psi00,
     +                      psiout, rho1, sigbulge2,
     +                      rmdisk, rdisk, zdisk, outdisk, drtrunc,
     +                      potcor1
      common /moreconstants/ v02, v03, rdisk2, diskconst, bulgea

c Lowered Evans density
      if (psi .ge. 0.0) then
         densrpsi=0
      else
         t2=sqrt(-2.*psi)
         r2 = r**2
         tpsiv02 = -2.0*psi/v02
         if( tpsiv02 .gt. 35 ) then
             e2psi = 0
         else
             e2psi = exp(-2.*psi/v02)
         endif
         densrpsi=2*pi*(
     +         (a*r2*v02*.03125 + 0.125*b)*v03
     +        *erfcen(2.0*t2/v0)*e2psi*e2psi
     +        +(c-a*r2*v02/2-b)*v03/sq8
     +        *erfcen(2.0*sqrt(-psi)/v0)*e2psi
     +        +a*v02*r2*(0.375*v02-psi/3.)*t2+b*0.5*v02*t2
     +        +c*(4./3.*psi-v02)*t2)
c         if (densrpsi.lt.0.) write(*,*) 'negative densrpsi at r,psi=',r,psi,densrpsi
         endif
      return
      end


      subroutine zlubksb(a,n,indx,bin,b)
c--- Adapted from Numerical Recipes
C--- back substitution for real a and complex b
c--- extended so that original vector b is not destroyed
      implicit none
      integer n,indx(n)
      double precision a(n,n)
      double complex b(n),bin(n),sum
      integer i,ii,j,ll
      b=bin
      ii=0
      do i=1,n
         ll=indx(i)
         sum=b(ll)
         b(ll)=b(i)
         if (ii.ne.0)then
            do j=ii,i-1
               sum=sum-dcmplx(a(i,j))*b(j)
            enddo               ! 11
         else if (sum.ne.dcmplx(0d0,0d0)) then
            ii=i
         endif
         b(i)=sum
      enddo                     ! 12
      do i=n,1,-1
         sum=b(i)
         if(i.lt.n)then
            do j=i+1,n
               sum=sum-dcmplx(a(i,j))*b(j)
            enddo               ! 13
         endif
         b(i)=sum/dcmplx(a(i,i))
      enddo                     ! 14
      return
      end


      MODULE m_dr2fdr
      CONTAINS

      SUBROUTINE dr2fdr(function,rmsh,jri,
     <                  deriv)
c
c     Construct r**2 * df(r)/dr ; input 'function' is on a mesh (rmsh)
c     with 'jri' points and is assumed to be multiplied by r**2.
c     difcub performs analytic derivative of Lagrangian of 3rd order.
c
      USE m_differentiate,ONLY:difcub
      IMPLICIT NONE

! Arguments ...

      INTEGER, INTENT (IN)  :: jri
      REAL,    INTENT (IN)  :: function(jri),rmsh(jri)
      REAL,    INTENT (OUT) :: deriv(jri)

! Locals ...

      INTEGER ir
      REAL faux(jri),xi

c
c take derivative of r**2 f(r): faux = d[r^2 f(r)]/dr
c first point
c
      xi = rmsh(1)
      faux(1) = difcub(rmsh(1),function(1),xi)
c
c 2nd to last-2
c
      DO ir = 2, jri - 2
         xi = rmsh(ir)
         faux(ir) = difcub(rmsh(ir-1),function(ir-1),xi)
      END DO
c
c last-1
c
      ir = jri - 1
      xi = rmsh(ir)
      faux(ir) = difcub(rmsh(jri-3),function(jri-3),xi)
c
c last point
c
      ir = jri
      xi = rmsh(ir)
      faux(ir) = difcub(rmsh(jri-3),function(jri-3),xi)
c
c calculate r^2 df(r)/dr = d[r^2 f(r)]/dr - 2 r f(r)
c
      DO ir = 1, jri
         deriv(ir) = faux(ir) - 2.0 * function(ir) / rmsh(ir)
      END DO

      RETURN
      END SUBROUTINE dr2fdr
      END MODULE m_dr2fdr


MODULE random_generator

  IMPLICIT NONE
  PRIVATE
  PUBLIC :: random, random_init, get_random_state, set_random_state
  INTEGER :: x = 123456789, y = 362436069, z = 521288629, w = 916191069

CONTAINS

  ! The  KISS (Keep It Simple Stupid) random number generator. Combines:
  ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
  ! (2) A 3-shift shift-register generator, period 2^32-1,
  ! (3) Two 16-bit multiply-with-carry generators,
  !     period 597273182964842497>2^59
  ! Overall period>2^123;  Default seeds x,y,z,w.
  ! Set your own seeds with random_init(ix,iy,iz,iw).
  FUNCTION random()

    DOUBLE PRECISION :: random
    INTEGER :: kiss, a1, b1, a2, b2, a3, b3

    x = 69069 * x + 1327217885

    a1 = y
    b1 = 13
    a2 = IEOR(a1, ISHFT(a1, b1))
    b2 = -17
    a3 = IEOR(a2, ISHFT(a2, b2))
    b3 = 5
    y  = IEOR(a3, ISHFT(a3, b3))

    z = 18000 * IAND(z, 65535) + ISHFT(z, - 16)
    w = 30903 * IAND(w, 65535) + ISHFT(w, - 16)

    kiss = x + y + ISHFT(z, 16) + w

    random = (DBLE(kiss) + 2147483648.d0) / 4294967296.d0

  END FUNCTION random

  SUBROUTINE random_init(seed)

    INTEGER, INTENT(IN) :: seed
    INTEGER :: i
    DOUBLE PRECISION :: dummy

    x = x + seed
    y = y + seed
    z = z + seed
    w = w + seed

    ! 'Warm-up' the generator by cycling through a few times
    DO i = 1, 1000
      dummy = random()
    ENDDO

  END SUBROUTINE random_init

  SUBROUTINE get_random_state(state)

    INTEGER, INTENT(OUT) :: state(:)

    state(1) = x
    state(2) = y
    state(3) = z
    state(4) = w

  END SUBROUTINE get_random_state

  SUBROUTINE set_random_state(state)

    INTEGER, INTENT(IN) :: state(:)

    x = state(1)
    y = state(2)
    z = state(3)
    w = state(4)

  END SUBROUTINE set_random_state

END MODULE random_generator


program main
  implicit none
  intrinsic :: selected_real_kind, size
  integer, parameter :: wp = selected_real_kind(15)
  integer :: i, dim1, dim2
  real(wp), allocatable, dimension(:, :) :: arr

  read (*, *) dim1, dim2

  allocate (arr(dim1, dim2))

  ! 1.000000000000000 2.000000000000000 3.000000000000000
  ! 1.000000000000000 2.000000000000000 3.000000000000000
  ! 1.000000000000000 2.000000000000000 3.000000000000000
  do i = 1, size(arr, 2) ! size(array, dimension <- optional)
    arr(:, i) = i
  end do

  write (*, *) "Array: ", arr

  deallocate (arr)
end program main


*> \brief \b ZGET52
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHA, BETA,
*                          WORK, RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       LOGICAL            LEFT
*       INTEGER            LDA, LDB, LDE, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   RESULT( 2 ), RWORK( * )
*       COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
*      $                   BETA( * ), E( LDE, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGET52  does an eigenvector check for the generalized eigenvalue
*> problem.
*>
*> The basic test for right eigenvectors is:
*>
*>                           | b(i) A E(i) -  a(i) B E(i) |
*>         RESULT(1) = max   -------------------------------
*>                      i    n ulp max( |b(i) A|, |a(i) B| )
*>
*> using the 1-norm.  Here, a(i)/b(i) = w is the i-th generalized
*> eigenvalue of A - w B, or, equivalently, b(i)/a(i) = m is the i-th
*> generalized eigenvalue of m A - B.
*>
*>                         H   H  _      _
*> For left eigenvectors, A , B , a, and b  are used.
*>
*> ZGET52 also tests the normalization of E.  Each eigenvector is
*> supposed to be normalized so that the maximum "absolute value"
*> of its elements is 1, where in this case, "absolute value"
*> of a complex value x is  |Re(x)| + |Im(x)| ; let us call this
*> maximum "absolute value" norm of a vector v  M(v).
*> If a(i)=b(i)=0, then the eigenvector is set to be the jth coordinate
*> vector. The normalization test is:
*>
*>         RESULT(2) =      max       | M(v(i)) - 1 | / ( n ulp )
*>                    eigenvectors v(i)
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] LEFT
*> \verbatim
*>          LEFT is LOGICAL
*>          =.TRUE.:  The eigenvectors in the columns of E are assumed
*>                    to be *left* eigenvectors.
*>          =.FALSE.: The eigenvectors in the columns of E are assumed
*>                    to be *right* eigenvectors.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The size of the matrices.  If it is zero, ZGET52 does
*>          nothing.  It must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA, N)
*>          The matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is COMPLEX*16 array, dimension (LDB, N)
*>          The matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of B.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is COMPLEX*16 array, dimension (LDE, N)
*>          The matrix of eigenvectors.  It must be O( 1 ).
*> \endverbatim
*>
*> \param[in] LDE
*> \verbatim
*>          LDE is INTEGER
*>          The leading dimension of E.  It must be at least 1 and at
*>          least N.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is COMPLEX*16 array, dimension (N)
*>          The values a(i) as described above, which, along with b(i),
*>          define the generalized eigenvalues.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          BETA is COMPLEX*16 array, dimension (N)
*>          The values b(i) as described above, which, along with a(i),
*>          define the generalized eigenvalues.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (N**2)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION array, dimension (2)
*>          The values computed by the test described above.  If A E or
*>          B E is likely to overflow, then RESULT(1:2) is set to
*>          10 / ulp.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16_eig
*
*  =====================================================================
      SUBROUTINE ZGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHA, BETA,
     $                   WORK, RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      LOGICAL            LEFT
      INTEGER            LDA, LDB, LDE, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RESULT( 2 ), RWORK( * )
      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
     $                   BETA( * ), E( LDE, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      CHARACTER          NORMAB, TRANS
      INTEGER            J, JVEC
      DOUBLE PRECISION   ABMAX, ALFMAX, ANORM, BETMAX, BNORM, ENORM,
     $                   ENRMER, ERRNRM, SAFMAX, SAFMIN, SCALE, TEMP1,
     $                   ULP
      COMPLEX*16         ACOEFF, ALPHAI, BCOEFF, BETAI, X
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, ZLANGE
      EXTERNAL           DLAMCH, ZLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZGEMV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   ABS1
*     ..
*     .. Statement Function definitions ..
      ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
*     ..
*     .. Executable Statements ..
*
      RESULT( 1 ) = ZERO
      RESULT( 2 ) = ZERO
      IF( N.LE.0 )
     $   RETURN
*
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFMAX = ONE / SAFMIN
      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
      IF( LEFT ) THEN
         TRANS = 'C'
         NORMAB = 'I'
      ELSE
         TRANS = 'N'
         NORMAB = 'O'
      END IF
*
*     Norm of A, B, and E:
*
      ANORM = MAX( ZLANGE( NORMAB, N, N, A, LDA, RWORK ), SAFMIN )
      BNORM = MAX( ZLANGE( NORMAB, N, N, B, LDB, RWORK ), SAFMIN )
      ENORM = MAX( ZLANGE( 'O', N, N, E, LDE, RWORK ), ULP )
      ALFMAX = SAFMAX / MAX( ONE, BNORM )
      BETMAX = SAFMAX / MAX( ONE, ANORM )
*
*     Compute error matrix.
*     Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| )
*
      DO 10 JVEC = 1, N
         ALPHAI = ALPHA( JVEC )
         BETAI = BETA( JVEC )
         ABMAX = MAX( ABS1( ALPHAI ), ABS1( BETAI ) )
         IF( ABS1( ALPHAI ).GT.ALFMAX .OR. ABS1( BETAI ).GT.BETMAX .OR.
     $       ABMAX.LT.ONE ) THEN
            SCALE = ONE / MAX( ABMAX, SAFMIN )
            ALPHAI = SCALE*ALPHAI
            BETAI = SCALE*BETAI
         END IF
         SCALE = ONE / MAX( ABS1( ALPHAI )*BNORM, ABS1( BETAI )*ANORM,
     $           SAFMIN )
         ACOEFF = SCALE*BETAI
         BCOEFF = SCALE*ALPHAI
         IF( LEFT ) THEN
            ACOEFF = DCONJG( ACOEFF )
            BCOEFF = DCONJG( BCOEFF )
         END IF
         CALL ZGEMV( TRANS, N, N, ACOEFF, A, LDA, E( 1, JVEC ), 1,
     $               CZERO, WORK( N*( JVEC-1 )+1 ), 1 )
         CALL ZGEMV( TRANS, N, N, -BCOEFF, B, LDA, E( 1, JVEC ), 1,
     $               CONE, WORK( N*( JVEC-1 )+1 ), 1 )
   10 CONTINUE
*
      ERRNRM = ZLANGE( 'One', N, N, WORK, N, RWORK ) / ENORM
*
*     Compute RESULT(1)
*
      RESULT( 1 ) = ERRNRM / ULP
*
*     Normalization of E:
*
      ENRMER = ZERO
      DO 30 JVEC = 1, N
         TEMP1 = ZERO
         DO 20 J = 1, N
            TEMP1 = MAX( TEMP1, ABS1( E( J, JVEC ) ) )
   20    CONTINUE
         ENRMER = MAX( ENRMER, TEMP1-ONE )
   30 CONTINUE
*
*     Compute RESULT(2) : the normalization error in E.
*
      RESULT( 2 ) = ENRMER / ( DBLE( N )*ULP )
*
      RETURN
*
*     End of ZGET52
*
      END


! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Program test_linalg
  Use mlf_linalg
  CALL test_real()
  CALL test_cmplx()
Contains
  Subroutine test_cmplx()
    complex(kind = 8) :: A(3,3), B(3), C(3)
    integer :: ier, ip(3), i
    A(1,:) = CMPLX([1, 0, -1], [-1, 1, 0], 8)
    A(2,:) = CMPLX([1, 1, 0], [0, -1, 0], 8)
    A(3,:) = CMPLX([1, -1, 1], [1, 0, -1], 8)
    C = CMPLX([2, 5, -3], [-2, 3, 1])
    PRINT *, "C: ", C
    B = MATMUL(A, C)
    PRINT *, "B: ", B
    ier = DecompMatrix(A, ip)
    PRINT *, ier, ip
    Do i = 1, 4
      PRINT *, A(i,:)
    End Do
    CALL SolveMatrix(A, B, ip)
    PRINT *, "B: ", B
  End Subroutine test_cmplx

  Subroutine test_real()
    real(8) :: A(4,4), B(4), C(4)
    integer :: ier, ip(4), i
    A(1,:) = [3, 2, 3, 4]
    A(2,:) = [4, 4, 3, 2]
    A(3,:) = [1, 4, 4, 3]
    A(4,:) = [2, 3, 1, 1]
    C = [1, -1, 2, -3]
    PRINT *, "C: ", C
    B = MATMUL(A, C)
    PRINT *, "B: ", B
    ier = DecompMatrix(A, ip)
    PRINT *, ier, ip
    Do i = 1, 4
      PRINT *, A(i,:)
    End Do
    CALL SolveMatrix(A, B, ip)
    PRINT *, "B: ", B
  End Subroutine test_real
End


! $UWHPSC/codes/io/binwrite.f90

! Illustrate writing out an array using binary (unformatted) vs. ASCII.
! Creates two files u.bin (binary) and u.txt (ASCII).
! The ASCII file should be three times larger if you do:
!  $  ls -l u.*

program binwrite

    integer, parameter :: m = 100, n = 500
    real(kind=8) :: u(m,n)

    open(unit=20, file="u.bin", form="unformatted", &
         status="unknown", access="stream")
    open(unit=21, file="u.txt")
    open(unit=22, file="mn.txt")

    do j=1,n
        do i=1,m
            u(i,j) = dble(m*(j-1) + i)
        enddo
     enddo

    write(20) u  ! writes array in binary

    write(21,'(e24.16)') u  ! writes array in ascii

    write(22,*) m,n

    close(20)

end program binwrite


PROGRAM A6Q1
!--
!Given an array A[1:n], returns the indices of an ordered version of array A
!--
IMPLICIT NONE
INTEGER, DIMENSION(:), ALLOCATABLE :: An
INTEGER :: n, check

PRINT *, "Retruns an array R such that A[R[i]] .le. A[R[J]] for 1 .ge. i < j .le. n"
DO
	PRINT *, "Please enter the length of array A (0 to stop)"
	READ *, n
    IF (n .eq. 0) STOP
    ALLOCATE(An(n), STAT=check)
    IF (check .ne. 0) THEN
      	PRINT *, "Allocation for A unsuccessful"
    ELSE
      	PRINT *, "Please enter the values for A"
        READ *, An
        PRINT *, FindOrder(An, n)
        DEALLOCATE(An)
    END IF
END DO

CONTAINS
FUNCTION FindOrder(A, n) RESULT (R)
INTEGER, DIMENSION(n), INTENT(IN) :: A
INTEGER, INTENT(IN) :: n
INTEGER, DIMENSION(n) :: B, R
INTEGER :: i, j, maxvalue, minvalue

!- We'll be working with the array A but don't want to change it
!- so lets define that the array B is A but we can change B
B = A
R = A
!- Find the largest element of the array,
!- then introduce a new element that is greater than the rest
maxvalue = B(1)
DO i = 1,n
  	IF (maxvalue .lt. B(i)) maxvalue = B(i)
END DO
maxvalue = maxvalue + 1
!- Sort through the array B and find the lowest value, and it's index.
!- once the min is found then replace it with our largest value found above.
minvalue = 1
DO i = 1,n
    DO j = 1,n
      	IF (B(minvalue) .gt. B(j)) minvalue = j
	END DO
    B(minvalue) = maxvalue
    R(i) = minvalue
END DO

END FUNCTION FindOrder
END PROGRAM


! very simple reduction
      program reduction
      integer n, i
      parameter(n=10)
      real a(n), s
!hpf$ processors P(4)
!hpf$ distribute a(block) onto P
!hpf$ independent
      do i=1, n
         a(i)=real(i)
      enddo
      s=0.33
!hpf$ independent, reduction(s)
      do i=2, n-1
         s = s * a(i)
      enddo
      print *, 'result is (should be near 119750.398)', s
      end


!  MPIHENON - Example main program for the MPI version of the Henon basin
!  uncertainty calculation.  All values are taken from a file named
!  on the command line (or 'henon.txt' otherwise).

    use, intrinsic::iso_fortran_env  ! Fortran 2003 and later
    use mpi
    use henondim
    use lsq
    use precision
    ! use henondim or whatever module contains your actual Henon basin code
    implicit none
    integer, parameter:: ROOT=0
    integer, parameter:: NEPS=10
    integer, parameter:: INTERNAL_ERROR=1  ! shell error code; must be nonzero

!  Local variables

    integer:: j, ierr, nargs, ierrfit
    real(DP),parameter:: HALF=0.5

!  These are the epsilon values requested in previous assignments, and you
!  will use the same values for this program.

    real(DP) :: epsilon(NEPS)=[(HALF**j, j=12,21)]

!  Map parameters, as a 2-vector

    real(DP) :: henonparams(2)  !  parameters a ,b
    integer  :: K        !  max number of iterations
    real(DP) :: LOCKOUT  !  threshold

!  Other variables

!  The first four values determine the X and Y limits of the grid,
!  and the second two values are the number of grid points.  XNUM and YNUM
!  are intended to be integer valued, but they are declared as double
!  precision so that they can be sent as a single message.  (As integer
!  values, XNUM and YNUM would have to be sent either as a separate
!  message, or all these values would have to be wrapped as a user-defined
!  type and registered with the MPI library.)

    real(DP):: xextent(6)  ! xmin, xmax, ymin, ymax, Nx, Ny

!  Other variables

    character(200):: errmsg='none'  ! sufficiently long for typical messages
    character(80):: filename='henon.txt'  ! default input file name
    integer:: uncert(NEPS)  ! number of uncertain points for each epsilon
    integer:: uncertsum(NEPS)  ! total number of uncertain points
    integer:: me  ! my MPI rank (0 = root process)
    integer:: npes  ! Number of Processing ElementS (> 0)
    real(DP) :: d, C(2)
    namelist/basinparams/ henonparams, xextent, K, LOCKOUT

!  Initialize.

    call mpi_init(ierr)  ! should be first executable statement
    call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)  ! my rank
    call mpi_comm_size(MPI_COMM_WORLD, npes, ierr) ! number of processes

!  Start the Henon basin computation.

    uncert=0

!  Read data on the root process and broadcast.  We MUST NOT allow the Fortran
!  runtime to kill the root process if the input data file cannot be opened or
!  if there is an i/o error.  Otherwise, the root process exits without
!  calling MPI_FINALIZE, the other processes hang while waiting from data
!  from the now-dead root process.
!  General rule: !  ALL i/o statements in an MPI Fortran program
!  should include the IOSTAT= and IOMSG= specifiers, and an appropriate
!  branch taken to display the error message and kill the entire MPI program.
!  Similarly, ALL exceptions in a C++ program must be caught in a global
!  catch{} block that takes analogous action.

    if(me.eq.ROOT) then
       nargs=command_argument_count()
       if(nargs.gt.0) call get_command_argument(1,filename)
       open(unit=4, file=filename, status='old', iostat=ierr, iomsg=errmsg)
       if(ierr.ne.0) goto 911
       read(4,basinparams,iostat=ierr,iomsg=errmsg)
       if(ierr.ne.0) goto 911
       close(4,iostat=ierr,iomsg=errmsg)  ! close the data file
       if(ierr.ne.0) goto 911
    endif

!  Broadcast the map parameters to everyone.
!  All processes must call MPI_BCAST to receive the broadcast messages.

    call mpi_bcast(henonparams, 2, MPI_DOUBLE, ROOT, MPI_COMM_WORLD, ierr)

!  Likewise, broadcast the grid extent and number of grid points in
!  each direction (as floating-point numbers).

    call mpi_bcast(xextent, size(xextent), MPI_DOUBLE, ROOT, MPI_COMM_WORLD, &
      ierr)

!  Once more, broadcast the max number of iterations K and the lockout parameter LOCKOUT.

    call mpi_bcast(K, 1, MPI_INT, ROOT, MPI_COMM_WORLD, ierr)
    call mpi_bcast(LOCKOUT, 1, MPI_DOUBLE, ROOT, MPI_COMM_WORLD, ierr)

!  The basi_alg subroutine will divide up the grid according to the number of
!  processes and calculate the number of uncertain points for each epsilon
!  on the correspoinding protion of the grid for that processor. It will return
!  an array of uncertain points (same dimension as the array of epsilons).

    call basin_alg(xextent, me, npes, henonparams, K, LOCKOUT, &
                                          epsilon, size(epsilon), uncert)

!  Sum up the total number of uncertain points from each process for each
!  epsilon and place the results on the root.  MPI computes a global sum
!  by adding corresponding elements of UNCERT from each process.
!  Other global operations include MPI_PROD (product), MPI_MAX (maximum of each
!  element), and MPI_MIN (minimum of each element).  It's also possible to
!  define your own, but we won't cover that topic here.

    call mpi_reduce(uncert, uncertsum, NEPS, MPI_INTEGER, MPI_SUM, ROOT, &
      MPI_COMM_WORLD, ierr)

!  Let the root process report the results on the standard output.
!  UNCERTSUM is undefined on the other processes.

    if(me.eq.ROOT) then
       do j=1, NEPS
         write(OUTPUT_UNIT,110,iostat=ierr,iomsg=errmsg) epsilon(j),uncertsum(j)
       enddo
       call linfit('Power',size(epsilon),epsilon,DBLE(uncertsum),C,ierrfit)
       if(ierrfit==0) then
         d=1+C(2)
         write(OUTPUT_UNIT,111,iostat=ierr,iomsg=errmsg) d
       endif
    endif
110 format(es13.6, 2x, i7)
111 format('d = ', f10.8)

!  Clean up and exit.

    call mpi_barrier(MPI_COMM_WORLD, ierr)  ! wait for everyone to finish
    call mpi_finalize(ierr)  ! should be last executable statement before STOP
    stop
!---------   End of normal computation

!  Exception handling:
!  Abort on i/o errors, because if we can't read the data on the root process,
!  then we can't compute a useful result.
!  Advice: when composing error messages, it is helpful to include the rank
!  of the MPI process, so you will know who is complaining.
!  Always write error messages to the standard error unit, not to the standard
!  output, as MPI launchers usually create separate error log files.
!  In such cases, your error messages won't get mixed in with other
!  computational output.  Error log files should be empty upon successful
!  completion or (if you desire) contain only debugging messages.

911 continue
    if(me.eq.ROOT) write(ERROR_UNIT,999) me, errmsg
999 format('MPI process ', i0, ': ', a)
    call mpi_abort(MPI_COMM_WORLD, INTERNAL_ERROR, ierr)
    end


INTEGER, PARAMETER :: N = 10
INTEGER :: i, j, Y(10,10)
INTEGER :: A(10,10), X(10), Z(10,10)
13 FORALL (I=1:N) A(I,I) = X(I)
FORALL (I=1:N, J=1:N) Z(I,J) = 1.0/REAL(I+J-1)
FORALL (I=1:N, J=1:N, Y(I,J) /= 0 .AND. I /= J) Z(I,J) = 1.0/Y(I,J)
END PROGRAM


   !        Generated by TAPENADE     (INRIA, Tropics team)
   !  Tapenade 3.10 (r5363) -  9 Sep 2014 09:53
   !
   !  Differentiation of cross_product_3d in forward (tangent) mode (with options noISIZE i4 dr8 r8):
   !   variations   of useful results: cross
   !   with respect to varying inputs: cross v1 v2
   ! ====================================================================
   ! File: vectorUtils.f90
   ! Author: C.A.(Sandy) Mader
   ! Date Started: July 14, 2014
   ! Date Modified:
   SUBROUTINE CROSS_PRODUCT_3D_D(v1, v1b, v2, v2b, cross, crossb)
   USE CONSTANTS
   IMPLICIT NONE
   REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: v1, v2
   REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: v1b, v2b
   REAL(kind=realtype), DIMENSION(3), INTENT(OUT) :: cross
   REAL(kind=realtype), DIMENSION(3), INTENT(OUT) :: crossb
   crossb(1) = v1b(2)*v2(3) + v1(2)*v2b(3) - v1b(3)*v2(2) - v1(3)*v2b(2)
   cross(1) = v1(2)*v2(3) - v1(3)*v2(2)
   crossb(2) = v1b(3)*v2(1) + v1(3)*v2b(1) - v1b(1)*v2(3) - v1(1)*v2b(3)
   cross(2) = v1(3)*v2(1) - v1(1)*v2(3)
   crossb(3) = v1b(1)*v2(2) + v1(1)*v2b(2) - v1b(2)*v2(1) - v1(2)*v2b(1)
   cross(3) = v1(1)*v2(2) - v1(2)*v2(1)
   END SUBROUTINE CROSS_PRODUCT_3D_D


subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)

    use amr_module, only: mcapa

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

    implicit none

    ! Input
    integer, intent(in) :: ixy, maxm, mx, meqn, mwaves, mbc, maux
    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) :: auxl(maux, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) :: auxr(maux, 1-mbc:maxm+mbc)

    ! Output
    real(kind=8), intent(in out) :: s(mwaves, 1-mbc:maxm+mbc)
    real(kind=8), intent(in out) :: fwave(meqn, mwaves, 1-mbc:maxm+mbc)
    real(kind=8), intent(in out) :: amdq(meqn,1-mbc:maxm+mbc)
    real(kind=8), intent(in out) :: apdq(meqn,1-mbc:maxm+mbc)

    ! Locals
    integer :: normal_dir, tangential_dir, i, mw
    real(kind=8) :: h_l, h_r, hu_l, hu_r, hv_l, hv_r, u_l, u_r, v_l, v_r
    real(kind=8) :: b_l, b_r, phi_l, phi_r

    real(kind=8) :: h_hat, u_hat, v_hat, c_hat

    real(kind=8) :: delta(3), beta(3)
    real(kind=8) :: dxdc

    ! Normal vs. Tangential directions
    if (ixy == 1) then
        normal_dir = 2
        tangential_dir = 3
    else
        normal_dir = 3
        tangential_dir = 2
    endif

    ! Main loop
    do i = 2 - mbc, mx + mbc

        ! Skip this cell interface if both cells are dry
        if (qr(1, i - 1) < dry_tolerance .and. ql(1, i) < dry_tolerance) then
            cycle
        end if

        ! Extract states
        h_l = qr(1, i - 1)
        h_r = ql(1, i)
        hu_l = qr(normal_dir, i - 1)
        hu_r = ql(normal_dir, i)
        hv_l = qr(tangential_dir, i - 1)
        hv_r = ql(tangential_dir, i)
        b_l = auxr(1, i - 1)
        b_r = auxl(1, i)

        ! Determine velocities
        if (h_l < dry_tolerance) then
            h_l = 0.d0
            u_l = 0.d0
            v_l = 0.d0
        else
            u_l = hu_l / h_l
            v_l = hv_l / h_l
        end if
        if (h_r < dry_tolerance) then
            h_r = 0.d0
            u_r = 0.d0
            v_r = 0.d0
        else
            u_r = hu_r / h_r
            v_r = hv_r / h_r
        end if

        ! Momentum flux
        phi_l = h_l * u_l**2 + 0.5d0 * g * h_l**2
        phi_r = h_r * u_r**2 + 0.5d0 * g * h_r**2

        ! Compute Roe averages
        h_hat = 0.5d0 * (h_r + h_l)
        u_hat = (sqrt(h_r) * u_r + sqrt(h_l) * u_l) / (sqrt(h_r) + sqrt(h_l))
        v_hat = (sqrt(h_r) * v_r + sqrt(h_l) * v_l) / (sqrt(h_r) + sqrt(h_l))
        c_hat = sqrt(g * h_hat)

        ! Flux differences
        delta(1) = hu_r - hu_l
        delta(normal_dir) = phi_r - phi_l + 0.5d0 * g * (h_r + h_l) * (b_r - b_l)
        delta(tangential_dir) = h_r * u_r * v_r - h_l * u_l * v_l

        ! Wave speeds - Einfeldt speeds
        s(1, i) = min(u_hat - c_hat, u_l - sqrt(g * h_l))
        s(3, i) = max(u_hat + c_hat, u_r + sqrt(g * h_r))
        s(2, i) = 0.5d0 * (s(1, i) + s(3, i))

        ! Wave strengths
        beta(1) = (s(3, i) * delta(1) - delta(2)) / (s(3, i) - s(1, i))
        beta(3) = (delta(2) - s(1, i) * delta(1)) / (s(3, i) - s(1, i))
        beta(2) = delta(3) - v_l * beta(1) - v_r * beta(3)

        ! F-Waves
        fwave(:, 1, i) = [1.d0, s(1, i), v_l] * beta(1)
        fwave(:, 2, i) = [0.d0, 0.d0, 1.d0] * beta(2)
        fwave(:, 3, i) = [1.d0, s(3, i), v_r] * beta(3)

    end do
    ! End of main loop

    ! Capacity mapping for lat-long grids
    if (mcapa > 0) then
        do i = 2 - mbc, mx + mbc
            if(ixy == 1) then
                dxdc = earth_radius * deg2rad
            else
                dxdc = earth_radius * cos(auxl(3, i)) * deg2rad
            end if

            s(:, i) = dxdc * s(:, i)
            fwave(:, :, i) = dxdc * fwave(:, :, i)
        end do
    end if

    ! Accumulate fluctuations
    do i = 2 - mbc, mx + mbc
        do mw = 1, mwaves
            if (s(mw, i) < 0.d0) then
                amdq(:, i) = amdq(:, i) + fwave(:, mw, i)
            else if (s(mw, i) > 0.d0) then
                apdq(:, i) = apdq(:, i) + fwave(:, mw, i)
            else
                amdq(:, i) = amdq(:, i) + 0.5d0 * fwave(:, mw, i)
                apdq(:, i) = apdq(:, i) + 0.5d0 * fwave(:, mw, i)
            end if
        end do
    end do

    print *, s
    stop

end subroutine rpn2


      program angle
      implicit double precision(a-h,o-z)

      real*8, allocatable :: c(:,:)
      character*2, allocatable :: lab(:)
      character*80 filename

      pi=2.d0*acos(0.d0)

      open(unit=1,file='xyzFILENAME',status='old')
      read(1,100)filename
      close(unit=1)
100   format(a80)
      open(unit=1,file=trim(filename),status='old')
      read(1,*)natom
      allocate(lab(natom))
      allocate(c(natom,3))
      read(1,*)
      do n=1,natom
       read(1,*)lab(n),(c(n,k),k=1,3)
      enddo

      read(5,*) n1,n2,n3
      r1=0.d0
      r2=0.d0
      r3=0.d0
      do k=1,3
        r1=r1+(c(n1,k)-c(n2,k))**2
        r2=r2+(c(n3,k)-c(n2,k))**2
        r3=r3+(c(n1,k)-c(n3,k))**2
      enddo
      anom=r1+r2-r3
      denom=2.d0*sqrt(r1*r2)
      ang=anom/denom
      ang=acos(ang)*180.d0/pi
      write(6,101)n1,n2,n3,ang
101   format(3i10,f13.6)
      end


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine getkncut(eta,a1,a2,a3,kncut,nm1,nm2,nm3)
c     ================================================================
c
      implicit   none
c
      integer    nm1
      integer    nm2
      integer    nm3
      integer    i
      integer    j
      integer    k
c
      real*8     eta
      real*8     a1(3)
      real*8     a2(3)
      real*8     a3(3)
      real*8     r(3)
      real*8     rm2
      real*8     term
      real*8     kncut
      real*8     fac
      real*8     epsi
c
      parameter (epsi=1.0d-14)
c
      fac=eta*eta/4.0d0
c
c     ================================================================
c     calculate nm1,nm2,nm3...........................................
c     ================================================================
      r(1)=a1(1)*a1(1)+a1(2)*a1(2)+a1(3)*a1(3)
      term=1.0d0
      nm1=0
      do while(term.gt.epsi)
         nm1=nm1+1
         rm2=nm1*nm1*r(1)
         term=exp(-fac*rm2)/rm2
      enddo
      r(2)=a2(1)*a2(1)+a2(2)*a2(2)+a2(3)*a2(3)
      term=1.0d0
      nm2=0
      do while(term.gt.epsi)
         nm2=nm2+1
         rm2=nm2*nm2*r(2)
         term=exp(-fac*rm2)/rm2
      enddo
      r(3)=a3(1)*a3(1)+a3(2)*a3(2)+a3(3)*a3(3)
      term=1.0d0
      nm3=0
      do while(term.gt.epsi)
         nm3=nm3+1
         rm2=nm3*nm3*r(3)
         term=exp(-fac*rm2)/rm2
      enddo
c
c     ================================================================
c     calculate kncut.................................................
c     ================================================================
      kncut=sqrt(r(1))*nm1
      do i=-1,1
	 r(1)=i*a1(1)*nm1
	 r(2)=i*a1(2)*nm1
	 r(3)=i*a1(3)*nm1
         do j=-1,1
	    r(1)=r(1)+j*a2(1)*nm2
	    r(2)=r(2)+j*a2(2)*nm2
	    r(3)=r(3)+j*a2(3)*nm2
            do k=-1,1
	       r(1)=r(1)+k*a3(1)*nm3
	       r(2)=r(2)+k*a3(2)*nm3
	       r(3)=r(3)+k*a3(3)*nm3
	       rm2=r(1)*r(1)+r(2)*r(2)+r(3)*r(3)
	       kncut=max(kncut,sqrt(rm2))
            enddo
         enddo
      enddo
c
      return
      end


c initialisation subroutine: initialises the common block with parameter
c values

       subroutine initanox (steadyparms)
       external steadyparms

       double precision parms(9)
       common /myparms/parms

       call steadyparms(9, parms)
       return
       end

c subroutine calculating the rate of change

       subroutine anoxmod (neq, t, y, ydot, yout, ip)
       implicit none
       double precision t, y(*), ydot(*), yout(*)
       double precision OM,O2,SO4,HS
       double precision min, oxicmin, anoxicmin
       integer neq, ip(*)
       double precision D, Flux, r, rox, ks, ks2, BO2, BSO4, BHS
       common /myparms/D, Flux, r, rox, ks, ks2, BO2, BSO4, BHS

         IF (ip(1) < 1) call rexit("nout should be at least 1")

         OM  = y(1)
         O2  = y(2)
         SO4 = y(3)
         HS  = y(4)

         Min       = r*OM
         oxicmin   = Min*(O2/(O2+ks))
         anoxicmin = Min*(1-O2/(O2+ks))* SO4/(SO4+ks2)

         ydot(1)  = Flux - oxicmin - anoxicmin
         ydot(2)  = -oxicmin      -2*rox*HS*(O2/(O2+ks)) + D*(BO2-O2)
         ydot(3)  = -0.5*anoxicmin  +rox*HS*(O2/(O2+ks)) + D*(BSO4-SO4)
         ydot(4)  =  0.5*anoxicmin  -rox*HS*(O2/(O2+ks)) + D*(BHS-HS)

c         yout(1) = SO4+HS

       return
       end


C --- ------------------------------ RESON_RADIA -------------------------------
      SUBROUTINE RESON_RADIA (line_nr,w,dw,n,divtn,broad,rescale)
C --- Calculates
C ---  i) the resonance broadening effect on Balmer lines ( H-alpha ...
C ---     ... H-epsilon ) according to Ali and Griem, Phys.Rev.
C ---     140A,1044 (1965) and 144,366 (1966),
C ---     see also ---> Cayrel and Traving, ZfA 50,239 (1960) and
C ---     Furssow and Wlassow, Phys. Z. Sowjetunion 10,378 (1936) .
C ---     Resonance damping constants GAMMA_RES of upper and lower levels
C ---     are simply added.
C --- ii) broadening due to radiation damping ( H-alpha .... H-delta )
C     Routine adapted from Klaus Fuhrmann

      INCLUDE 'physcnst.inc'                     ! physical constants
      INCLUDE 'lf_decl0.inc'                     ! general declarations

      INTEGER*4 line_nr                          ! Nr of Balmerline (H-alpha=1)
                                  ! line_nr = 1,2,3,4,5 <=> H-alpha...H-epsilon
      REAL*4    gamma_res
      REAL*4    gamma_rad
      REAL*4    alpha
      REAL*4    alpha2
      REAL*4    w2
      REAL*4    aii(6,7)
      REAL*4    l1nf1n(6)                        ! lam(1,n) * f(1,n)
      REAL*4    c3
      REAL*8    rescale

      DATA l1nf1n/.5059619e-5,.811345e-6,.281938e-6,
     *            .132394 e-6,.73139 e-7,.44806 e-7/
      DATA aii/   0.,        0.,        0.,        0.,        0., 0.,
     *     4.699E+08,        0.,        0.,        0.,        0., 0.,
     *     5.575E+07, 4.410E+07,        0.,        0.,        0., 0.,
     *     1.278E+07, 8.419E+06, 8.986E+06,        0.,        0., 0.,
     *     4.125E+06, 2.530E+06, 2.201E+06, 2.699E+06,        0., 0.,
     *     1.644E+06, 9.732E+05, 7.783E+05, 7.711E+05, 1.010E+06, 0.,
     *            0.,        0.,        0.,        0.,        0., 0./ ! dummies
C            LYMAN     BALMER     PASCHEN    BRACKETT    PFUND

      gamma_res = 0.
      gamma_rad = 0.

      c3 = C3FAC * (l1nf1n(1) + l1nf1n(line_nr+1))
      gamma_res = PI2_4_DIV_K * c3 * divtn *
     *                   atm.pion(n,1,1)/atm.uion(n,1,1)
      gamma_rad = aii(1,2)

      DO i = 1,line_nr+1
        gamma_rad = gamma_rad + aii(i,line_nr+2)
      END DO

      w2     = w * w
      alpha  = (gamma_res*rescale + gamma_rad) * w2 * DIV_4PIC
      alpha2 = alpha * alpha
      broad  = alpha / ( (dw*dw) + alpha2 ) * DIV_PIC * w2

      RETURN
      END


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!   This module computes the means drift forces using the far-field momentum formulation for a finite depth
!   case according to equation 4.7 and 4.8 of R1
!
!  R1 Computation of Higher-Order Hydrodynamic Forces on Ships and Offshore Structures in Waves
!             http://dspace.mit.edu/bitstream/handle/1721.1/79979/42664020.pdf?sequence=1
!
! Contest Drift forces and QTF Implementation of Nemoh
!
! Changes in version 1.1 (Implementation of Higher Order Panel Methods)
!       Added COMMON_TYPE module as dependency
!
! Changes in version 1.2 (Dipoles Implementation in NEMOH)
!       Switch from ParamsCommon to ParamsCommonInf
!
!   @author yedtoss
!   @version 1.2

module COMPUTE_MEAN_DRIFT_FORCES_FIN

    USE COMMON_TYPE
    USE COM_VAR
    USE UTILITY
    USE KOCHIN

    implicit none

contains

    function driftintegralfin_fx(theta, param)
        ! computes abs(H(theta))**2*cos(theta)
        USE KOCHIN
        REAL, INTENT(IN) :: theta
        REAL :: driftintegralfin_fx
        TYPE(ParamsCommonInf) :: param
        COMPLEX :: HKochin

        CALL COMPUTE_KOCHIN(param%kwave, theta, HKochin, param%SolverVar)

        driftintegralfin_fx = (ABS(HKochin)**2)*COS(theta)

    end function driftintegralfin_fx

    function driftintegralfin_fy(theta, param)
        ! computes abs(H(theta))**2*sin(theta)

        USE KOCHIN
        REAL, INTENT(IN) :: theta
        REAL :: driftintegralfin_fy
        TYPE(ParamsCommonInf) :: param
        COMPLEX :: HKochin

        CALL COMPUTE_KOCHIN(param%kwave, theta, HKochin, param%SolverVar)

        driftintegralfin_fy = (ABS(HKochin)**2)*SIN(theta)

    end function driftintegralfin_fy

    subroutine compute_mean_drift_forces_finite(param, drift_forces)
        ! This is the main subrouting computing the drift_forces
        ! It use romberg_trap to integrate the function driftintegral_fy and driftintegral_fx

        REAL :: PI
        TYPE(ParamsCommonInf) :: param
        REAL, DIMENSION(2) :: drift_forces
        REAL :: const
        REAL :: m0
        REAL :: CgC
        REAL:: Z
        COMPLEX :: HKochin

        PI=4.*ATAN(1.)

        m0 = param%AMH

        Cgc = 0.5*(1 + 2*m0*Depth/sinh(2*m0*Depth))

        Z = (m0**2-param%kwave**2)/(param%kwave**2*Depth-m0**2*Depth-param%kwave)*cosh(m0*Depth)**2

        const = -(RHO*G*param%AKH**2/m0)*CgC

        drift_forces(1) =const*(Z**2/(4*PI)*romberg_trap(driftintegralfin_fx, 0., 2*PI, 1e-3, 20, param))
        drift_forces(2) = const*(Z**2/(4*PI)**romberg_trap(driftintegralfin_fy, 0., 2*PI, 1e-3, 20, param))

        CALL COMPUTE_KOCHIN(param%kwave, PI+param%beta, HKochin, param%SolverVar)

        drift_forces(1) = drift_forces(1) + (const)*Z*cos(param%beta)*aimag(HKochin)
        drift_forces(2) = drift_forces(2) + (const)*Z*sin(param%beta)*aimag(HKochin)

    end subroutine compute_mean_drift_forces_finite
end module COMPUTE_MEAN_DRIFT_FORCES_FIN


#define NX 50
#define NY 50
#define NZ 50

program main
  implicit none

  double precision, dimension(NX,NY,NZ) :: u,v
  double precision, dimension(NX,NY,NZ) :: u_other,v_other
  integer t
  call init()

  call fapp_start("main", 0,0)
  call start_collection("kantai")
  do t = 1, 8*1024
     call proceed(u,v, u_other, v_other)
     call proceed(u_other,v_other, u, v)
  end do
  call stop_collection("kantai")
  call fapp_stop("main", 0,0)

  print *, u(25,25,25), v(25,25,25)

contains
  subroutine init()
    integer x,y,z
    do z = 1, NZ
       do y = 1, NY
          do x = 1, NX
             u(x,y,z) = 1.0
             v(x,y,z) = 0.0
          end do
       end do
    end do
    do z = NZ*4/10, NZ*6/10
       do y = NY*4/10, NY*6/10
          do x = NX*4/10, NX*6/10
             u(x,y,z) = 0.5
             v(x,y,z) = 0.25
          end do
       end do
    end do

  end subroutine init

  subroutine proceed(u,v,u_next,v_next)
    double precision, intent(in) ,dimension(NX,NY,NZ) :: u,v
    double precision, intent(out),dimension(NX,NY,NZ) :: u_next,v_next

    double precision, parameter :: rU = 1.0/86400.0, rV = 6.0/86400.0, rE = 1.0/900.0
    double precision, parameter :: Du = 2.3e-10, Dv = 6.1e-11, dt = 200, dx = 0.001
    double precision u0, v0, eat, du_dt, dv_dt, lap_u, lap_v
    integer x,y,z,x0,y0,z0

    do z0 = 1, (NZ-2)/2
       do y0 = 1, NY-2
          do x0 = 1, NX-2
             x=x0+1
             y=z0+1
             z=2*z0
             u0 = u(x,y,z)
             v0 = v(x,y,z)
             eat = rE * u0 * v0 * v0
             lap_u = u(x+1,y,z)+u(x-1,y,z)+u(x,y+1,z)+u(x,y-1,z)+u(x,y,z+1)+u(x,y,z-1)-6.0*u(x,y,z)
             lap_v = v(x+1,y,z)+v(x-1,y,z)+v(x,y+1,z)+v(x,y-1,z)+v(x,y,z+1)+v(x,y,z-1)-6.0*v(x,y,z)
             du_dt = -eat + rU * (1.0-u0) + Du/dx/dx * lap_u
             dv_dt =  eat - rV * v0 + Dv/dx/dx * lap_v
             u_next(x0,y0,z-1) = u0 + du_dt * dt
             v_next(x0,y0,z-1) = v0 + dv_dt * dt
             ! x=x0+1
             ! y=z0+1
             z=2*z0+1
             u0 = u(x,y,z)
             v0 = v(x,y,z)
             eat = rE * u0 * v0 * v0
             lap_u = u(x+1,y,z)+u(x-1,y,z)+u(x,y+1,z)+u(x,y-1,z)+u(x,y,z+1)+u(x,y,z-1)-6.0*u(x,y,z)
             lap_v = v(x+1,y,z)+v(x-1,y,z)+v(x,y+1,z)+v(x,y-1,z)+v(x,y,z+1)+v(x,y,z-1)-6.0*v(x,y,z)
             du_dt = -eat + rU * (1.0-u0) + Du/dx/dx * lap_u
             dv_dt =  eat - rV * v0 + Dv/dx/dx * lap_v
             u_next(x0,y0,z-1) = u0 + du_dt * dt
             v_next(x0,y0,z-1) = v0 + dv_dt * dt
          end do
       end do
    end do

  end subroutine proceed

end program main


!######################################################################
!# MODULE: likesubprograms
!#
!# AUTHORS:
!#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca>,
!#         Waleed Almutiry <wkmtierie@qu.edu.sa>, and
!#         Rob Deardon <robert.deardon@ucalgary.ca>
!#
!# DESCRIPTION:
!#
!#     Calculates log-likelihood for spatial and network individual-level models with two
!#     disease types: SI and SIR
!#
!# Algorithm based on:
!#
!#     Deardon R, Brooks, S. P., Grenfell, B. T., Keeling, M. J., Tildesley,
!#     M. J., Savill, N. J., Shaw, D. J.,  Woolhouse, M. E. (2010).
!#     Inference for individual level models of infectious diseases in large
!#     populations. Statistica Sinica, 20, 239-261.
!#
!#     This program is free software; you can redistribute it and/or
!#     modify it under the terms of the GNU General Public License,
!#     version 2, as published by the Free Software Foundation.
!#
!#     This program is distributed in the hope that it will be useful,
!#     but without any warranty; without even the implied warranty of
!#     merchantability or fitness for a particular purpose. See the GNU
!#     General Public License, version 2, for more details.
!#
!#     A copy of the GNU General Public License, version 2, is available
!#     at http://www.r-project.org/Licenses/GPL-2
!#
!# Part of the R/EpiILM package
!# Contains:
!#            like     .................. subroutine
!#            likesir  .................. subroutine
!#            likecon    .................. subroutine
!#            likeconsir .................. subroutine
!######################################################################

    module likesubprograms
    use ISO_C_BINDING
    implicit none
    public :: like, likesir, likecon, likeconsir

    contains

    subroutine like(x, y, tau, n, tmin, tmax, ns, nt, ni, alpha, phi, beta, &
                   & spark, covmatsus, covmattrans, val) bind(C, name="like_")
    !log-likelihood for purely spatial model: SI
    implicit none

    !Declarations
    integer (C_INT), intent(in) :: n, tau(n), tmax, ns, nt, ni, tmin
    real (C_DOUBLE), intent(in) :: alpha(ns), phi(nt), beta(ni), spark  !parameters
    real (C_DOUBLE), intent(in) :: x(n), y(n)                  !locations
    real (C_DOUBLE), intent(in) :: covmatsus(n, ns), covmattrans(n, nt)               !covariates
    real (C_DOUBLE), intent(out):: val                         !result

    integer (C_INT)          :: i, j, t
    real (C_DOUBLE) :: Somega(n), Tomega(n)
    real (C_DOUBLE) :: dx1, dx2, p1, p2

    !Calculate the distance matrix
!    do i = 1, n
!      do j = i, n
!        eu(i,j) = sqrt(((x(i)-x(j))**2) + ((y(i)-y(j))**2))
!        eu(j,i) = eu(i,j)
!      end do
!    end do

    Somega = matmul(covmatsus,alpha) !susceptibility function
    Tomega = matmul(covmattrans,phi) !transmissibility function

    val = 0.0_c_double
    do t = tmin, (tmax-1)
      do i = 1, n
    !infectious period
        if (tau(i)==(t+1)) then
          dx1 = 0.0_c_double
          do j = 1, n
            if ((tau(j) .LT. (t+1)) .AND. (tau(j) .NE. 0)) then
              dx1 = dx1 + ((sqrt(((x(i)-x(j))**2) + ((y(i)-y(j))**2)) **(-beta(ni)))*Tomega(j))
            end if
          end do
        p1 = 1.0_c_double - exp(-((Somega(i) * dx1) + spark))
        val = val + log(p1)
        end if
        !susceptible period
        if ((tau(i) .GT. (t+1)) .OR. (tau(i) == 0)) then
          dx2 = 0.0_c_double
          do j = 1, n
            if ((tau(j) .LT. (t+1)) .AND. (tau(j) .NE. 0))then
              dx2 = dx2 + ((sqrt(((x(i)-x(j))**2) + ((y(i)-y(j))**2)) **(-beta(ni)))*Tomega(j))
            end if
          end do
        p2 = exp(-((Somega(i) * dx2) + spark))
        val = val + log(p2)  !result
        end if
      end do
    end do

    end subroutine like

!######################################################################

    subroutine likesir(x, y, tau, lambda, n, tmin, tmax, ns, nt, ni, alpha, &
                     & phi, beta, spark, covmatsus, covmattrans, val) bind(C, name="likesir_")
    !log-likelihood for purely spatial model: SIR
    implicit none

    !Declarations
    integer (C_INT), intent(in) :: n, tau(n), lambda(n), tmax, ns, nt, ni, tmin
    real (C_DOUBLE), intent(in) :: alpha(ns), beta(ni), phi(nt), spark  !parameters
    real (C_DOUBLE), intent(in) :: x(n), y(n)                  !locations
    real (C_DOUBLE), intent(in) :: covmatsus(n, ns), covmattrans(n, nt)               !covariates
    real (C_DOUBLE), intent(out):: val                         !result

    integer (C_INT) :: i, j, t
    real (C_DOUBLE) :: Somega(n), Tomega(n)
    real (C_DOUBLE) :: dx1, dx2, p1, p2

    !Calculate the distance matrix
!    do i = 1, n
!      do j = i, n
!        eu(i,j) = sqrt(((x(i)-x(j))**2) + ((y(i)-y(j))**2))
!        eu(j,i) = eu(i,j)
!      end do
!    end do

    Somega = matmul(covmatsus, alpha) !susceptibility function
    Tomega = matmul(covmattrans, phi) !transmissibility function

    val = 0.0_c_double
    do t = tmin, (tmax-1)
      do i = 1, n
    !infectious period
        if (tau(i)==(t+1)) then
          dx1 = 0.0_c_double
            do j = 1, n
              if (tau(j) .NE. 0) then
                if ((tau(j) .LT. (t+1)) .AND. (tau(j) + lambda(j) .GE. (t+1))) then
                  dx1 = dx1 + ((sqrt(((x(i)-x(j))**2) + ((y(i)-y(j))**2)) **(-beta(ni)))*Tomega(j))
                end if
              end if
            end do
         p1 = 1.0_c_double - exp(-((Somega(i) * dx1) + spark))
         val = val + log(p1)
        end if
        !susceptible period
        if ((tau(i) .GT. (t+1)) .OR. (tau(i)== 0))then
          dx2 = 0.0_c_double
            do j = 1, n
              if (tau(j) .NE. 0) then
                if ((tau(j) .LT. (t+1)) .AND. (tau(j)+lambda(j) .GE. (t+1)))then
                  dx2 = dx2 + ((sqrt(((x(i)-x(j))**2) + ((y(i)-y(j))**2)) **(-beta(ni)))*Tomega(j))
                end if
              end if
            end do
          p2 = exp(-((Somega(i) * dx2) + spark))
          val = val + log(p2)  !result
        end if
      end do
    end do

    end subroutine likesir

!######################################################################

    subroutine likecon(tau, n, ns, nt, ni, tmin, tmax, alpha, phi, beta, &
                      & spark, covmatsus, covmattrans, network, val) bind(C, name="likecon_")
    !log-likelihood for contact network model: SI
    implicit none

    !Declarations
    integer (C_INT), intent(in)  :: n, tmax, ns, nt, ni, tmin
    integer (C_INT), intent(in)  :: tau(n)                     !infection times
    real (C_DOUBLE), intent(in)  :: alpha(ns), phi(nt), beta(ni), spark !parameters
    real (C_DOUBLE), intent(in)  :: covmatsus(n,ns), covmattrans(n,nt)               !covariates
    real (C_DOUBLE), intent(in)  :: network(n,n,ni)            !contact network
    real (C_DOUBLE), intent(out) :: val                        !result

    integer (C_INT) :: i, j, t, k
    real (C_DOUBLE) :: dx1, dx2, p1, p2, Somega(n), Tomega(n)

    Somega = matmul(covmatsus,alpha) !susceptibility function
    Tomega = matmul(covmattrans,phi) !transmissibility function

    val = 0.0_c_double
    do t = tmin, (tmax-1)
      do i = 1, n
      !infectious period
        if (tau(i)==(t+1)) then
         dx1 = 0.0_c_double
            do j = 1, n
              if ((tau(j) .LT. (t+1)) .AND. (tau(j) .NE. 0)) then
                do k = 1, ni
                  dx1 = dx1 + ((beta(k) * network(i,j,k))*Tomega(j))
                end do
              end if
            end do
         p1 = 1.0_c_double - exp(-((Somega(i) * dx1) + spark))
         val = val + log(p1)
        end if
        !susceptible period
        if ((tau(i) .GT. (t+1)) .OR. (tau(i)== 0))then
         dx2 = 0.0_c_double
            do j = 1, n
              if ((tau(j) .LT. (t+1)) .AND. (tau(j) .NE. 0))then
                do k = 1, ni
                  dx2 = dx2 + ((beta(k) * network(i,j,k))*Tomega(j))
                end do
              end if
            end do
         p2 = exp(-((Somega(i) * dx2) + spark))
         val = val + log(p2)  !result
        end if
     end do
    end do

    end subroutine likecon

!######################################################################

    subroutine likeconsir(tau, lambda, n, ns, nt, ni, tmin, tmax, alpha, phi, beta, &
         & spark, covmatsus, covmattrans, network, val) bind(C, name="likeconsir_")
    !log-likelihood for contact network model: SIR
    implicit none

    !Declarations
    integer (C_INT), intent(in)  :: n, tmax, ns, nt, ni, tmin
    integer (C_INT), intent(in)  :: tau(n), lambda(n)          !inftime and infperiod
    real (C_DOUBLE), intent(in)  :: alpha(ns), phi(nt), beta(ni), spark !parameters
    real (C_DOUBLE), intent(in)  :: covmatsus(n,ns), covmattrans(n,nt)               !covariates
    real (C_DOUBLE), intent(in)  :: network(n,n,ni)            !contact network
    real (C_DOUBLE), intent(out) :: val                        !result

    integer (C_INT)  :: i, j, t, k
    real (C_DOUBLE)  :: dx1, dx2, p1, p2, Somega(n), Tomega(n)

    Somega = matmul(covmatsus,alpha) !susceptibility function
    Tomega = matmul(covmattrans,phi) !transmissibility function

    val = 0.0_c_double
    do t = tmin, (tmax-1)
      do i = 1, n
      !infectious period
        if (tau(i)==(t+1)) then
         dx1 = 0.0_c_double
            do j = 1, n
              if ((tau(j) .LT. (t+1)) .AND. (tau(j) .NE. 0) .AND. &
                       & (tau(j)+lambda(j) .GE. (t+1))) then
                 do k = 1, ni
                   dx1 = dx1 + ((beta(k) * network(i, j, k))*Tomega(j))
                 end do
              end if
            end do
         p1 = 1.0_c_double - exp(-((Somega(i) * dx1) + spark))
         val = val + log(p1)
        end if
        !susceptible period
        if ((tau(i) .GT. (t+1)) .OR. (tau(i)== 0))then
         dx2 = 0.0_c_double
            do j = 1, n
              if ((tau(j) .LT. (t+1)) .AND. (tau(j) .NE. 0) .AND.&
                     & (tau(j)+lambda(j) .GE. (t+1)))then
                do k = 1, ni
                  dx2 = dx2 + ((beta(k) * network(i,j,k))*Tomega(j))
                end do
              end if
            end do
         p2 = exp(-((Somega(i) * dx2) + spark))
         val = val + log(p2)  !result
        end if
      end do
    end do

    end subroutine likeconsir

    end module likesubprograms