SUBROUTINE era_matrix (mjd, ERM, CRS2TRS, TRS2CRS, d_CRS2TRS, d_TRS2CRS)

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Subroutine:  era_matrix.f90
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Purpose:
!  Earth Rotation matrix (approximate) based only on the Earth Rotation angle
!  without considering any corrections (see Note 1)
!  Simplified approach to the transformation matrix between Inertial and Earth-fixed systems
!  based only to the Earth Rotation matrix.
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Note 1:
! The Earth Rotation Angle is computed based on the IERS Conventions 2010 formula.
! The UT1-UTC difference is considered as zero (approximate approach)
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Input arguments:
! - mjd:			Modified Julian Day number of the epoch (in TT scale)
!
! Output arguments:
! - ERM:			Earth Rotation matrix
! - CRS2TRS:		Inertial to Terrestrial reference system transformation matrix
! - TRS2CRS:		Terrestrial to Inertial reference system transformation matrix
! - d_CRS2TRS:		Derivative of Inertial to Terrestrial reference system transformation matrix
! - d_TRS2CRS:		Derivative of Terrestrial to Inertial reference system transformation matrix
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Dr. Thomas Papanikolaou, Geoscience Australia            September 2016
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: mjd
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: ERM(3,3)
      REAL (KIND = prec_d), INTENT(OUT) :: CRS2TRS(3,3), TRS2CRS(3,3)
      REAL (KIND = prec_d), INTENT(OUT) :: d_CRS2TRS(3,3), d_TRS2CRS(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Called Functions (F77)
      DOUBLE PRECISION iau_ERA00
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC, mjd_UT1
      DOUBLE PRECISION TT1, TT2, TT1_UT1, TT2_UT1, TAI1, TAI2
      INTEGER (KIND = prec_int8) :: mjd_UTC_day
      DOUBLE PRECISION PR(3,3)
      DOUBLE PRECISION JD_ut1, Tu

      DOUBLE PRECISION xp, yp, UT1_UTC, dX_eop, dY_eop
      DOUBLE PRECISION xp_rad, yp_rad, arcsec2rad, sp_iau00
      REAL (KIND = prec_d) :: X_iau00A,Y_iau00A,s_iau00A , X_iau06,Y_iau06,s_iau06
      REAL (KIND = prec_d) :: X_iau,Y_iau,s_iau , X_pn,Y_pn

      DOUBLE PRECISION RPOM(3,3), RPOM_T(3,3)
      DOUBLE PRECISION RC2I(3,3), RC2I_T(3,3)
      DOUBLE PRECISION R_era(3,3), era, R_era_n(3,3), era_n
      DOUBLE PRECISION Qt(3,3), Qt_inv(3,3), Rt(3,3), Rt_inv(3,3), Wt(3,3), Wt_inv(3,3)
      DOUBLE PRECISION GCRS2TIRS(3,3)
      DOUBLE PRECISION QR(3,3), Wi_Ri(3,3)
      DOUBLE PRECISION dtheta, P_dR (3,3), P_dR_T(3,3)
      DOUBLE PRECISION QP(3,3), QPR(3,3), QPRW(3,3), Ri_Qi(3,3), PT_Ri_Qi(3,3), Wi_PT_RiQi(3,3)
! ----------------------------------------------------------------------

      arcsec2rad = PI_global / (3600.0D0 * 180.0D0)

! ----------------------------------------------------------------------
! The UT1-UTC difference is considered as zero (approximate approach)
UT1_UTC = 0.D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Time Systems transformation
! ----------------------------------------------------------------------
      CALL time_TT (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
! ----------------------------------------------------------------------
! TT
      TT1 = 2400000.5D0
      TT2 = mjd_TT
! ----------------------------------------------------------------------
! TAI
      TAI1 = 2400000.5D0
      TAI2 = mjd_TAI
! ----------------------------------------------------------------------
! UTC
      mjd_UTC_day = INT (mjd_UTC)
! ----------------------------------------------------------------------
! UT1
      mjd_UT1 = mjd_UTC + UT1_UTC / 86400.D0
      TT1_UT1 = 2400000.5D0
      TT2_UT1 = mjd_UT1
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth Rotation Matrix (ERM) | R(t)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth Rotation Angle: era (in radians)
! ----------------------------------------------------------------------

era = iau_ERA00 ( TT1_UT1, TT2_UT1 )

! ----------------------------------------------------------------------
if (1 < 0) then

JD_ut1 = TT1_UT1 + TT2_UT1
Tu = JD_ut1 - 2451545.0D0

era = (2.D0*PI_global) * ( 0.7790572732640D0 + 1.00273781191135448D0 * Tu )

if (era > 2.D0*PI_global) then
	era = era - INT(era / (2.D0*PI_global) ) * (2.D0*PI_global)
end if

end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Rotation Matrices initialization: set them to singular I3x3
! R3(ERA)
      R_era(1,1) = 1D0
      R_era(1,2) = 0D0
      R_era(1,3) = 0D0
      R_era(2,1) = 0D0
      R_era(2,2) = 1D0
      R_era(2,3) = 0D0
      R_era(3,1) = 0D0
      R_era(3,2) = 0D0
      R_era(3,3) = 1D0

! R3(-ERA)
      R_era_n = R_era
! ----------------------------------------------------------------------

! R(t)^T = R3(ERA)
      !CALL iau_RZ ( era, R_era )
! Rotation matrix
      R_era(1,1:3) = (/  cos(era),  sin(era),	0.D0 /)
      R_era(2,1:3) = (/ -sin(era),  cos(era),	0.D0 /)
      R_era(3,1:3) = (/		 0.D0,		0.D0, 	1.D0 /)

! R(t) = R3(-ERA)
      era_n = -1.0D0 * era
!      CALL iau_RZ ( era_n, R_era_n )
      R_era_n(1,1:3) = (/  cos(era_n),  sin(era_n),	0.D0 /)
      R_era_n(2,1:3) = (/ -sin(era_n),  cos(era_n),	0.D0 /)
      R_era_n(3,1:3) = (/		 0.D0,		  0.D0, 1.D0 /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth Rotation matrix
ERM = R_era_n
! ----------------------------------------------------------------------

Rt = R_era_n
Rt_inv = R_era

! ----------------------------------------------------------------------
! CRS-TRS transformation matrix (direct/inverse)
! ----------------------------------------------------------------------
! ITRS to GCRS transformation matrix
TRS2CRS = Rt

! GCRS to ITRS transformation matrix
CRS2TRS = Rt_inv
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Derivatives of CRS-TRS transformation matrix (direct/inverse)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth angular velocity
! ----------------------------------------------------------------------
! IERS 2010;
!      dtheta = 0.7292115D0 * 10.0D-04
! ----------------------------------------------------------------------
! Omega as derivative of Earth Rotation Angle (ERA), dERA/dt in rad/s
      dtheta = 2.0D0 * PI_global * 1.00273781191135448D0 * (1.0D0 / 86400D0)
! ----------------------------------------------------------------------

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%% Computation of derivative of TRS2CRS matrix
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! d_TRS2CRS = d(TRS2CRS)/dt = (dtheta * P * Rt)
! ----------------------------------------------------------------------
!P = [ 0  -1   0
!      1   0   0
!      0   0   0 ] ;

      P_dR (1,1) =  0.0D0
      P_dR (1,2) = -1.0D0
      P_dR (1,3) =  0.0D0
      P_dR (2,1) =  1.0D0
      P_dR (2,2) =  0.0D0
      P_dR (2,3) =  0.0D0
      P_dR (3,1) =  0.0D0
      P_dR (3,2) =  0.0D0
      P_dR (3,3) =  0.0D0
! ----------------------------------------------------------------------
CALL iau_RXR ( P_dR, Rt, PR )
d_TRS2CRS = dtheta * PR
! ----------------------------------------------------------------------

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%% Computation of derivative of CRS2TRS matrix
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! d_CRS2TRS = omega * P^T * R(-t) ;
! ----------------------------------------------------------------------
CALL iau_TR ( P_dR, P_dR_T )
CALL iau_RXR ( P_dR_T, Rt_inv, PR )
d_CRS2TRS = dtheta * PR
! ----------------------------------------------------------------------

END


MODULE FUN_xyQUADRILATERAL
!!#### PURPOSE
!! Determine the QUADRILATERAL connecting the points in the list.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### EXTERNAL PARAMETERS
USE PAR_ComputationalGeometry                  !!((02-A-PAR_ComputationalGeometry.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyCONVEXHULL                           !!((07-B-FUN_xyCONVEXHULL.f90))
USE FUN_xyCOLINEAR                             !!((05-B-FUN_xyCOLINEAR.f90))
USE FUN_xyCONTIGUOUS                           !!((06-B-FUN_xyCONTIGUOUS.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyQUADRILATERAL_Lsx
 MODULE PROCEDURE xyQUADRILATERAL_Lsx_Rsp
 MODULE PROCEDURE xyQUADRILATERAL_Lsx_Rdp
END INTERFACE

INTERFACE xyQUADRILATERAL_P4
 MODULE PROCEDURE xyQUADRILATERAL_P4_Rsp
 MODULE PROCEDURE xyQUADRILATERAL_P4_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyQUADRILATERAL_Lsx
PUBLIC :: xyQUADRILATERAL_P4

CONTAINS

PURE FUNCTION xyQUADRILATERAL_Lsx_Rsp( N , Lsx ) RESULT(xyQg)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyQUADRILATERAL_Lsx.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyQUADRILATERAL_Lsx.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyQUADRILATERAL_Lsx_Rdp( N , Lsx ) RESULT(xyQg)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyQUADRILATERAL_Lsx.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyQUADRILATERAL_Lsx.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyQUADRILATERAL_P4_Rsp( P4 ) RESULT(xyQg)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyQUADRILATERAL_P4.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyQUADRILATERAL_P4.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyQUADRILATERAL_P4_Rdp( P4 ) RESULT(xyQg)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyQUADRILATERAL_P4.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyQUADRILATERAL_P4.f90.bdy"
!!--end--
END FUNCTION

END MODULE


! { dg-do run }
!
! PR fortran/51250
! Wrong loop shape for SUM when arguments are library-allocated arrays.
!
! Original testcase provided by Harald Anlauf <anlauf@gmx.de>

program gfcbug115
  implicit none
  integer :: n_obstype = 2
  integer :: nboxes = 1
  integer :: nprocs = 1
  integer :: nbox, j
  integer, allocatable :: nbx(:,:), pes(:)

  allocate (pes(nboxes))
  allocate (nbx(n_obstype,nboxes))
  nbx(:,:) = 1
  do j = 1, nboxes
     pes(j) = modulo (j-1, nprocs)
  end do
  if (any(nbx /= 1)) call abort
  do j = 0, nprocs-1
     if (.not. all(spread (pes==j,dim=1,ncopies=n_obstype))) call abort
     ! The two following tests used to fail
     if (any(shape(sum(nbx,dim=2,mask=spread (pes==j,dim=1,ncopies=n_obstype))) &
             /= (/ 2 /))) call abort
     if (any(sum (nbx,dim=2,mask=spread (pes==j,dim=1,ncopies=n_obstype)) &
             /= (/ 1, 1 /))) call abort
  end do
end program gfcbug115


! { dg-do compile }
!
! Check whether BESXY functions take scalars and
! arrays as arguments (PR31760).
!
PROGRAM test_erf
  REAL :: r = 0.0, ra(2) = (/ 0.0, 1.0 /)

  r  = BESJ0(r)
  r  = BESJ1(r)
  r  = BESJN(0, r)

  r  = BESY0(r)
  r  = BESY1(r)
  r  = BESYN(0, r)

  ra = BESJ0(ra)
  ra = BESJ1(ra)
  ra = BESJN(0, ra)

  ra = BESY0(ra)
  ra = BESY1(ra)
  ra = BESYN(0, ra)

  r  = BESSEL_J0(r)
  r  = BESSEL_J1(r)
  r  = BESSEL_JN(0, r)

  r  = BESSEL_Y0(r)
  r  = BESSEL_Y1(r)
  r  = BESSEL_YN(0, r)

  ra = BESSEL_J0(ra)
  ra = BESSEL_J1(ra)
  ra = BESSEL_JN(0, ra)

  ra = BESSEL_Y0(ra)
  ra = BESSEL_Y1(ra)
  ra = BESSEL_YN(0, ra)

END PROGRAM


!*==izamax.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b IZAMAX
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       INTEGER FUNCTION IZAMAX(N,ZX,INCX)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       COMPLEX*16 ZX(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)|
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] ZX
!> \verbatim
!>          ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of ZX
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup aux_blas
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, 1/15/85.
!>     modified 3/93 to return if incx .le. 0.
!>     modified 12/3/93, array(1) declarations changed to array(*)
!> \endverbatim
!>
!  =====================================================================
      INTEGER FUNCTION IZAMAX(N,Zx,Incx)
      IMPLICIT NONE
!*--IZAMAX75
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      INTEGER Incx , N
!     ..
!     .. Array Arguments ..
      COMPLEX*16 Zx(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      DOUBLE PRECISION dmax
      INTEGER i , ix
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DCABS1
      EXTERNAL DCABS1
!     ..
      IZAMAX = 0
      IF ( N<1 .OR. Incx<=0 ) RETURN
      IZAMAX = 1
      IF ( N==1 ) RETURN
      IF ( Incx==1 ) THEN
!
!        code for increment equal to 1
!
         dmax = DCABS1(Zx(1))
         DO i = 2 , N
            IF ( DCABS1(Zx(i))>dmax ) THEN
               IZAMAX = i
               dmax = DCABS1(Zx(i))
            ENDIF
         ENDDO
      ELSE
!
!        code for increment not equal to 1
!
         ix = 1
         dmax = DCABS1(Zx(1))
         ix = ix + Incx
         DO i = 2 , N
            IF ( DCABS1(Zx(ix))>dmax ) THEN
               IZAMAX = i
               dmax = DCABS1(Zx(ix))
            ENDIF
            ix = ix + Incx
         ENDDO
      ENDIF
      END FUNCTION IZAMAX


C NCLFORTSTART
      subroutine wksmooth121 (vv,vn,nn,spv,dum)
      implicit none
      integer nn,vn
      double precision vv(vn), spv, dum(vn)
C NCLEND

c Smooths vv by passing it through a 1-2-1 filter.
c The first and last points are given 3-1 (1st) or 1-3 (last)
c weightings (Note that this conserves the total sum).
c The routine also skips-over missing data (spv)
c There are 'nn' pieces of useful information, which may be less
c than or equal to 'vn'.

      integer i

      i = 0
 10   continue
      i = i+1
      if (vv(i).eq.spv) then
          dum(i) = spv
      elseif(i.eq.1) then
          if(vv(i+1).ne.spv) then
             dum(i) = (3.0d0*vv(i)+vv(i+1))/4.0d0
          else
             dum(i) = vv(i)
          end if
      elseif(vv(i-1).eq.spv) then
          if(vv(i+1).ne.spv) then
             dum(i) = (3.0d0*vv(i)+vv(i+1))/4.0d0
          else
             dum(i) = vv(i)
          end if
      elseif(i.eq.nn.or.vv(i+1).eq.spv) then
          if(vv(i-1).ne.spv) then
             dum(i) = (vv(i-1)+3.0d0*vv(i))/4.0d0
          else
             dum(i) = vv(i)
          end if
      else
           dum(i) = (1.0d0*vv(i-1)+2.0d0*vv(i)+1.0d0*vv(i+1))/4.0d0
      end if
      if (i.ne.nn) go to 10

      do i = 1,nn
         vv(i) = dum(i)
      enddo
      end

C NCLFORTSTART
       subroutine wktapertozero(ts,N,nmi,nn,tp)
       implicit none
       integer  N, nmi, nn, tp
       double precision ts(N)
C NCLEND

c "taper" the first and last 'tp' members of 'ts' by multiplication by
c a segment of the cosine curve so that the ends of the series
c taper toward zero. This satisfies the
c periodic requirement of the FFT.
c Only the data from nmi to nmi+nn-1 is deemed useful, and
c the rest is set to zero. (There are nn points of useful data)
       integer i,j
       double precision Pi
c c c  parameter (Pi = 3.1415926)   !tp is number to taper on each end.

       Pi = 4.0d0*atan(1.0d0)

       if (N.lt.25.or.nn.lt.25) then
        print*,'wktapertozero: No tapering if less than 25 values!'
c c c   STOP
        return
       end if
       if (nmi+nn-1.gt.N) then
        print*,'wktapertozero: ERROR as nmi+nn-1 > N'
        STOP
       end if

       do i = 1,N
        j = i-nmi+1
        if (j.le.0.or.j.gt.nn) then
         ts(i) = 0.0d0
        elseif (j.le.tp) then
         ts(i) =  ts(i)*0.5d0*(1.0d0-COS((j-1)*Pi/dble(tp)))
        elseif (j.gt.(nn-tp).and.j.le.nn) then
         ts(i) =  ts(i)*0.5d0*(1.0d0-COS((nn-j)*Pi/dble(tp)))
        else
         ts(i) =  ts(i)
        end if
       enddo

       return
       end

C NCLFORTSTART
       subroutine wkdetrend(X2,nx,vmi,nv)
       implicit none
       integer  nx, nv, vmi
       double precision X2(nx)
C NCLEND

c Removes the linear-squares best fit line for the series.
c Only the data from vmi to vmi+nv-1 is deemed useful, and
c the rest is zeroed. (There are nv points of useful data)
c The line of best fit is given by X2'  =  a + bX1.
c The X1s are assumed to be evenly spaced ( i.e. X1 = dble(i) )
c
c m1  =  mean of X1
c m2  =  mean of X2
c m3  =  mean of (X1*X2)
c m4  =  mean of (X1*X1)
c m5  =  mean of (X2*X2)

       integer i
       real m1,m2,m3,m4,m5,r,a,b

       if (vmi+nv-1.gt.nx) then
        print*,'wkdtrend:ERROR as vmi+nv-1 > nx'
        STOP
       end if

       m1 = 0.0d0
       m2 = 0.0d0
       m3 = 0.0d0
       m4 = 0.0d0
       m5 = 0.0d0

       do i = vmi,vmi+nv-1
        m1  =  m1+dble(i)/dble(nv)
        m2  =  m2+X2(i)/dble(nv)
        m3  =  m3+(dble(i)*X2(i))/dble(nv)
        m4  =  m4+(dble(i)*dble(i))/dble(nv)
        m5  =  m5+(X2(i)*X2(i))/dble(nv)
       end do

       r = (m3-m1*m2)/(sqrt(m4-m1**2)*sqrt(m5-m2**2))
       b = (m3-m1*m2)/(m4-m1**2)
       a = m2-b*m1

       do i = vmi,vmi+nv-1
        X2(i)  =  X2(i) - (a + b*dble(i))
       end do
c      print*,'Trend line has a = ',a,' b = ',b

       if (vmi.gt.1) then
           do i = 1,vmi-1
              X2(i)  =  0.0d0
           end do
       end if
       if (vmi+nv.le.nx) then
           do i = vmi+nv,nx
              X2(i) =  0.0d0
           end do
       end if

       return
       end


! Interpolation module to interface with python
! Compile with "f2py -c -m finterpolate interpolate.f90"
! Import and use in python with:
! >>>import finterpolate
! >>>finterpolate.interpolate.{function name}(arguments)
module interpolate
    implicit none

    public to_level

    contains

        ! Interpolate the input variable to levels defined by coord_out.
        ! Interpolate in the vertical to the highest point in coord_in with the desired value from coord out
        subroutine to_level(variable, coord_in, coord_out, type, order, np, nz, ny, nx, output, mask)
            !F2PY integer, intent(hide) :: np
            !F2PY integer, intent(hide) :: nz
            !F2PY integer, intent(hide) :: ny
            !F2PY integer, intent(hide) :: nx
            !F2PY real   , intent(in)   :: variable(nz,ny,nx)
            !F2PY real   , intent(in)   :: coord_in(nz,ny,nx)
            !F2PY real   , intent(in)   :: coord_out(np,ny,nx)
            !F2PY integer, intent(in)   :: type
            !F2PY integer, intent(in)   :: order
            !F2PY real   , intent(out)  :: output(np,ny,nx)
            !F2PY logical, intent(out)  :: mask(np,ny,nx)

            !-Input variables-
            ! Grid Dimensions
            integer, intent(in) :: np, nz, ny, nx

            ! Input Field
            real, intent(in) :: variable(nz, ny, nx)

            ! Vertical coord on same levels as input field
            real, intent(in) :: coord_in(nz, ny, nx)

            ! Vertical coord levels to interpolate to
            real, intent(in) :: coord_out(np, ny, nx)

            ! Interpolation type
            ! 0 = Linear
            ! 1 = Log-Linear
            ! 2 = Lagrange
            integer, intent(in) :: type

            ! Order of Lagrange polynomial interpolation
            integer, intent(in) :: order

            !-Output Variables-
            ! Output field interpolated to given levels
            real, intent(out) :: output(np, ny, nx)
            logical, intent(out) :: mask(np, ny, nx)

            !-Local Variables-
            integer :: i, j, k, l
            real :: z

            !-START-
            ! Loop over zcoord_out points
            do l=1,np
                do i=1,nx
                    do j=1,ny
                        z = coord_out(l,j,i)
                        if (out_of_bounds(z, coord_in(:,j,i), nz)) then
                            ! Set the mask to True if the requested value is not within the bounds of zcoord
                            mask(l, j, i) = .True.
                        else
                            ! Set the mask to False and do the interpolation if the requested value is within the
                            ! bounds of zcoord
                            mask(l, j, i) = .False.

                            ! Find the index of the first zcoord point that has crossed the output coordinate by
                            ! searching downwards
                            k = search_downwards(z, coord_in(:,j,i), nz)

                            ! Interpolate to the output point
                            if (type == 0) then
                                output(l,j,i) = linear(variable(:,j,i), coord_in(:,j,i), z, k, nz)
                            else if (type == 1) then
                                output(l,j,i) = log_linear(variable(:,j,i), coord_in(:,j,i), z, k, nz)
                                !else if (type == 2)
                                ! output(l,j,i) = lagrange(z, coord(:,j,i), k, nz)
                            end if
                        end if
                    end do
                end do
            end do

        end subroutine to_level
        !-------------------------------------------------------------------------------

        ! Search downwards to find the index where zcoord first crosses the value z.
        ! Before using this function it must be checked that z is within the bounds of zcoord
        function search_downwards(z, zcoord, nz)
            integer :: search_downwards

            !-Input Variables-
            real, intent(in) :: z, zcoord(nz)
            integer, intent(in) :: nz

            !-Local variables-
            integer :: k
            integer :: plusminus_at_top

            !-START-
            plusminus_at_top = plusminus(z - zcoord(nz))
            k = nz - 1
            do while (plusminus_at_top == plusminus(z-zcoord(k)))
                k = k-1
            end do

            search_downwards = k
        end function search_downwards

        ! Check whether the value z is contained within zcoord
        pure function out_of_bounds(z, zcoord, nz)
            logical :: out_of_bounds

            !-Input Variables-
            real, intent(in) :: z, zcoord(nz)
            integer, intent(in) :: nz

            !-Local variables-
            real :: zmax, zmin
            integer :: k

            !-START-
            zmax = zcoord(1)
            zmin = zcoord(1)
            do k=2, nz
                zmax = max(zmax, zcoord(k))
                zmin = min(zmin, zcoord(k))
            end do

            out_of_bounds = z > zmax.or.z < zmin
        end function out_of_bounds

        ! Calculate the interpolation weight assuming linear variation across two points
        function linear(variable, coord, z, k, nz)

            real :: linear

            !-Input Variables-
            real, intent(in) :: variable(nz), coord(nz), z
            integer, intent(in) :: k, nz

            !-Local Variables-
            ! Interpolation weight
            real :: alpha

            !-START-
            alpha = (z - coord(k)) / (coord(k+1) - coord(k))
            linear = alpha * variable(k+1) + (1 - alpha) * variable(k)
        end function linear

        ! Calculate the interpolation weight assuming linear logarithmic variation across two points
        pure function log_linear(variable, coord, z, k, nz)
            real :: log_linear

            !-Input Variables-
            real, intent(in) :: variable(nz), coord(nz), z
            integer, intent(in) :: k, nz

            !-Local Variables-
            ! Interpolation weight
            real :: alpha

            !-START-
            alpha = log(z / coord(k)) / log(coord(k+1) / coord(k))
            log_linear = alpha * variable(k+1) + (1 - alpha) * variable(k)
        end function log_linear

        ! Check whether x is positive or negative
        pure function plusminus(x)
            integer :: plusminus

            !-Input Variables-
            real, intent(in) :: x

            !-START-
            if (x < 0.0) then
                plusminus = -1
            else
                plusminus = 1
            end if
        end function plusminus

end module interpolate


module b2
  use b1
contains
  subroutine s()
    != unit c :: foo
    real, parameter :: foo = 273.0
    != unit c :: tc
    != unit k :: t
    real :: tc, t

    tc = k2c*t - foo
  end subroutine s
end module b2


use sysdyn

implicit none

logical                               :: fini = .false.
logical                               :: fpar = .false.
logical                               :: ftra = .false.
logical                               :: fend = .false.
logical                               :: plot = .false.

character(len=180)                    :: ifile = 'lorenz.ini'
character(len=180)                    :: pfile = 'lorenz.params'
character(len=180)                    :: tfile = 'lorenz.dat'
character(len=180)                    :: efile = 'lorenz.end'

logical                               :: fto = .false.
logical                               :: ftf = .false.
logical                               :: fdt = .false.

real(dp)                              :: to = zero
real(dp)                              :: tf = 20.0_dp
real(dp)                              :: dt = 0.01_dp

integer                               :: na,ierr,step,nsteps
real(dp), dimension(lorenz_n)         :: x,xo,xn
real(dp)                              :: time

namelist /PARAMS/ lorenz_sigma, lorenz_beta, lorenz_rho

call header()

! ... Lineargs
! ...
call lineargs_ini(na)

call argstr('-pa',fpar,pfile)
call argstr('-i',fini,ifile)
call argstr('-tr',ftra,tfile)
call argstr('-e',fend,efile)
call argdbl('-to',fto,to)
call argdbl('-tf',ftf,tf)
call argdbl('-te',ftf,tf)
call argdbl('-dt',fdt,dt)
call argflg('-pl',plot)

! ... Model parameters
! ... It tries to open the file lorenz.params
! ... If it fails, the parameters are the default ones from sysdyn
! ...
write(*,*)
open(1,file=pfile,status='old',iostat=ierr)
if (ierr.eq.0) then
  write(*,*) 'Reading lorenz model parameters from file: ', trim(pfile)
  rewind(1)
  read(1,nml=PARAMS)
  close(1)
else
  write(*,*) 'Using default lorenz parameters'
endif

write(*,*) 'sigma = ', lorenz_sigma
write(*,*) 'beta  = ', lorenz_beta
write(*,*) 'rho   = ', lorenz_rho
write(*,*)

! ... Model initial conditions
! ... It tries to open the file lorenz.ini
! ... If it fails, the parameters are the default ones from sysdyn
! ...
open(1,file=ifile,status='old',iostat=ierr)
if (ierr.eq.0) then
  write(*,*) 'Reading initial condition from file: ', trim(ifile)
  read(1,*) time, xo(:)
  if (.not.fto) to = time
else
  write(*,*) 'Using default initial condition'
  xo(:) = lorenz_ini(:)
endif

write(*,*) 'xo = ', xo
write(*,*)

nsteps = abs((tf - to)/dt)
write(*,*)
write(*,*) 'Initial time  = ', to
write(*,*) 'Final   time  = ', tf
write(*,*) 'Time interval = ', dt
write(*,*) 'Model steps   = ', nsteps

! ... Opening output trajectory:
! ...
write(*,*)
write(*,*) 'Opening output trajectory: ', trim(tfile)
open(10,file=trim(tfile),status='unknown')
write(10,'(4F10.4)') to, xo

! =============================================================
! ... Run the model
! ...

time = to
x(:) = xo(:)
do step=1,nsteps
  call rk4(lorenz_n,x,time,dt,xn,lorenz_rhs)
  time = time + dt
  x(:) = xn(:)
  write(10,'(4F10.4)') time, x
enddo
close(10)
! =============================================================

write(*,*) 'Opening file for final state: ', trim(efile)
open(10,file=trim(efile),status='unknown')
write(10,*) time, x
close(10)

! ... Call python to plot the results if option -plot has been used
! ...
if (plot) call system('python3 lorenz.py '//trim(tfile))

call stop_error(0,'lorenz model Ok')
end


program test_insert
use iso_fortran_env, only:int8, int16, int32, int64, real32, real64, real128
use testing, only:assert, initialize_tests, report_tests
use functional

implicit none

logical, dimension(:), allocatable :: tests
logical :: test_failed
integer :: n, ntests

n = 1
ntests = 13
call initialize_tests(tests, ntests)

tests(n) = assert(all(insert(2_int8, 2, [1_int8, 3_int8]) == [1, 2, 3]), &
                  'insert,  int8')
n = n + 1

tests(n) = assert(all(insert(2_int16, 2, [1_int16, 3_int16]) == [1, 2, 3]), &
                  'insert,  int16')
n = n + 1

tests(n) = assert(all(insert(2_int32, 2, [1_int32, 3_int32]) == [1, 2, 3]), &
                  'insert,  int32')
n = n + 1

tests(n) = assert(all(insert(2_int64, 2, [1_int64, 3_int64]) == [1, 2, 3]), &
                  'insert,  int64')
n = n + 1

tests(n) = assert(all(insert(2._real32, 2, [1._real32, 3._real32]) == [1, 2, 3]), &
                  'insert,  real32')
n = n + 1

tests(n) = assert(all(insert(2._real64, 2, [1._real64, 3._real64]) == [1, 2, 3]), &
                  'insert,  real64')
n = n + 1

tests(n) = assert(all(insert(2._real128, 2, [1._real128, 3._real128]) == [1, 2, 3]), &
                  'insert,  real128')
n = n + 1

tests(n) = assert(all(insert(cmplx(2._real32, 0._real32), 2, &
                             [cmplx(1._real32, 0._real32), cmplx(3._real32, 0._real32)])&
                       == arange(cmplx(1._real32, 0._real32), cmplx(3._real32, 0._real32))), &
                  'insert,  real32')
n = n + 1

tests(n) = assert(all(insert(cmplx(2._real64, 0._real64), 2, &
                             [cmplx(1._real64, 0._real64), cmplx(3._real64, 0._real64)])&
                       == arange(cmplx(1._real64, 0._real64), cmplx(3._real64, 0._real64))), &
                  'insert,  real64')
n = n + 1

tests(n) = assert(all(insert(cmplx(2._real128, 0._real128), 2, &
                             [cmplx(1._real128, 0._real128), cmplx(3._real128, 0._real128)])&
                       == arange(cmplx(1._real128, 0._real128), cmplx(3._real128, 0._real128))), &
                  'insert,  real128')
n = n + 1

tests(n) = assert(insert('ell', 2, 'Ho') == 'Hello', &
                  'insert character string')
n = n + 1

tests(n) = assert(all(insert(1, 1, arange(1, 0)) == [1]), &
                  'insert into empty array')
n = n + 1

tests(n) = assert(all(insert(2, 2, [1]) == [1, 2]), &
                  'insert out of bounds')
n = n + 1

test_failed = .false.
call report_tests(tests, test_failed)
if(test_failed)stop 1

end program test_insert


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

!	OpenMP parallel do with reduction

	program p
	 implicit none
	 integer n
	 parameter(n=10)
	 real a(0:n),b(n)
	 real result(n+3)
	 real expect(n+3)
	 data expect/1.,3.,5.,7.,9.,11.,13.,15.,17.,19.,
     &		     1.,38.,203./
	 integer i
	 real p1,p2,p3
	 do i = 0,n
	  a(i) = 2*i
	 enddo
	 p1 = 1.0
	 p2 = 2.0
	 p3 = 3.0
	 call sp2(a,b,n,p1,p2,p3)
	 do i = 1,n
	  result(i) = b(i)
	 enddo
	 result(n+1) = p1
	 result(n+2) = p2
	 result(n+3) = p3
!	print *,p1,p2,p3
!	print *,b
	 call check(result,expect,n+3)
	end

	subroutine sp2(a,b,n,p1,p2,p3)
	 implicit none
	 integer n
	 real a(0:n),b(n)
	 integer i
	 real p1,p2,p3
!$omp   parallel do private(p1) reduction(max:p2) reduction(+:p3)
	do i = 1,n
	 p1 = a(i) + a(i-1)
	 p2 = max(p2,p1)
	 p3 = p3 + p1
	 b(i) = (p1)/2.0
	enddo
	end


! lrc_lj_module.f90
! Long-range and delta corrections for potential energy and pressure
MODULE lrc_module

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! The purpose of this module is simply to gather in one place the common
  ! functions for long-range and delta corrections for the Lennard-Jones potential.
  ! If a different potential is used in the simulation, a different file
  ! (with the same module name) containing different expressions should be substituted

  IMPLICIT NONE
  PRIVATE

  ! Public routines
  PUBLIC :: potential_lrc, pressure_lrc, pressure_delta

  ! Private data
  REAL, PARAMETER :: pi = 4.0 * ATAN(1.0)

CONTAINS

  FUNCTION potential_lrc ( density, r_cut )
    IMPLICIT NONE
    REAL                :: potential_lrc ! Returns long-range correction to potential/atom
    REAL,    INTENT(in) :: density       ! Number density N/V
    REAL,    INTENT(in) :: r_cut         ! Cutoff distance

    ! Calculates long-range correction for Lennard-Jones potential per atom
    ! density, r_cut, and the results, are in LJ units where sigma = 1, epsilon = 1

    REAL :: sr3

    sr3 = 1.0 / r_cut**3

    potential_lrc = pi * ( (8.0/9.0)  * sr3**3  - (8.0/3.0)  * sr3 ) * density

  END FUNCTION potential_lrc

  FUNCTION pressure_lrc ( density, r_cut )
    IMPLICIT NONE
    REAL                :: pressure_lrc ! Returns long-range correction to pressure
    REAL,    INTENT(in) :: density      ! Number density N/V
    REAL,    INTENT(in) :: r_cut        ! Cutoff distance

    ! Calculates long-range correction for Lennard-Jones pressure
    ! density, r_cut, and the results, are in LJ units where sigma = 1, epsilon = 1

    REAL :: sr3

    sr3 = 1.0 / r_cut**3

    pressure_lrc = pi * ( (32.0/9.0) * sr3**3  - (16.0/3.0) * sr3 ) * density**2

  END FUNCTION pressure_lrc

  FUNCTION pressure_delta ( density, r_cut )
    IMPLICIT NONE
    REAL                :: pressure_delta ! Returns delta correction to pressure
    REAL,    INTENT(in) :: density        ! Number density N/V
    REAL,    INTENT(in) :: r_cut          ! Cutoff distance

    ! Calculates correction for Lennard-Jones pressure
    ! due to discontinuity in the potential at r_cut
    ! density, r_cut, and the results, are in LJ units where sigma = 1, epsilon = 1

    REAL :: sr3

    sr3 = 1.0 / r_cut**3

    pressure_delta = pi * (8.0/3.0) * ( sr3**3  - sr3 ) * density**2

  END FUNCTION pressure_delta

END MODULE lrc_module


! Copyright (c) 2014, Daniel Pena
! 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.

! 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 OWNER 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_MHEAP

   USE MHEAP

   DOUBLE PRECISION :: NODE(2)
   TYPE(THEAP) :: H
   INTEGER     :: K

   ! Init a heap with comparison function GREATER1, that
   ! compares the nodes' first component to order the heap
   CALL H%INIT( 10, 2, GREATER1 )

   ! insert some data
   CALL H%INSERT( [ 1.0D0, 2.0D0] )
   CALL H%INSERT( [-1.0D0, 8.0D0] )
   CALL H%INSERT( [ 5.0D0, 1.0D0] )
   CALL H%INSERT( [ 2.0D0,-1.0D0] )
   CALL H%INSERT( [-6.0D0, 5.0D0] )
   CALL H%INSERT( [ 3.0D0, 2.0D0] )

   ! Data is kept unordered (except for the root node)
   WRITE(*,*)
   WRITE(*,*) 'Unordered traversal, the first element is always the root node'
   DO K = 1, H%N
      CALL H%PEEK( K, NODE )
      WRITE(*,*) NODE
   ENDDO

   ! When the root node is popped, a new root node is set.
   ! To traverse it in order just pop all the root elements.
   WRITE(*,*)
   WRITE(*,*) 'Ordered traversal'
   DO K = 1, H%N
      CALL H%POP(NODE)
      WRITE(*,*) NODE
   ENDDO
   WRITE(*,*) 'Now heap is empty:', H%N

   ! Data is not lost from the tree when using pop,
   ! we can reheap the whole tree and start over
   WRITE(*,*) 'Tree data is kept after popping, so as long'
   write(*,*) 'as no new insertions are made, the same data'
   write(*,*) 'can be reheaped using the same or another function.'
   WRITE(*,*)
   WRITE(*,*) 'Reheap using same function'
   CALL H%REHEAP()
   DO K = 1, H%N
      CALL H%POP(NODE)
      WRITE(*,*) NODE
   ENDDO

   WRITE(*,*)
   WRITE(*,*) 'Reheap using other function'
   CALL H%REHEAP( GREATER2 )
   DO K = 1, H%N
      CALL H%POP(NODE)
      WRITE(*,*) NODE
   ENDDO

   WRITE(*,*)
   WRITE(*,*) 'Pop half the elements'
   CALL H%REHEAP( GREATER2 )
   DO K = 1, H%N / 2
      CALL H%POP(NODE)
      WRITE(*,*) NODE
   ENDDO
   WRITE(*,*) 'Insert 2 new elements'
   CALL H%INSERT( [ 2.0D0, 10.0D0] )
   CALL H%INSERT( [ 3.0D0,-10.0D0] )
   WRITE(*,*) 'Pop all'
   DO K = 1, H%N
      CALL H%POP(NODE)
      WRITE(*,*) NODE
   ENDDO

CONTAINS

   LOGICAL FUNCTION GREATER1( NODE1, NODE2 )
      DOUBLE  PRECISION, INTENT(IN) :: NODE1(:), NODE2(:)
      GREATER1 = NODE1(1) < NODE2(1)
   END FUNCTION GREATER1

   LOGICAL FUNCTION GREATER2( NODE1, NODE2 )
      DOUBLE PRECISION, INTENT(IN) :: NODE1(:), NODE2(:)
      GREATER2 = NODE1(2) < NODE2(2)
   END FUNCTION GREATER2

END PROGRAM TEST_MHEAP


! =========================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =========================================================

! solve Riemann problems for the 1D advection equation q_t + u*q_x = 0.
! For constant advection velocity u, passed in common block.

! waves:     1
! equations: 1

! Conserved quantities:
!       1 q

! The advection speed u is passed in the common block cparam
! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q

! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routine step1, rp is called with ql = qr = q.

    implicit double precision (a-h,o-z)
    double precision ::   ql( meqn,1-mbc:maxmx+mbc)
    double precision ::   qr( meqn,1-mbc:maxmx+mbc)
    double precision ::   amdq( meqn,1-mbc:maxmx+mbc)
    double precision ::   apdq( meqn,1-mbc:maxmx+mbc)
    double precision ::    s(mwaves,1-mbc:maxmx+mbc)
    double precision :: wave(meqn, mwaves,1-mbc:maxmx+mbc)
    common /cparam/ u

    do 30 i=2-mbc,mx+mbc

    !        # Compute the wave and speed

        wave(1,1,i) = ql(1,i) - qr(1,i-1)
        s(1,i) = u
        amdq(1,i) = dmin1(u, 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(u, 0.d0) * wave(1,1,i)
    30 END DO

    return
    end subroutine rp1


c
c
c     =====================================================
      subroutine rpt2(ixy,maxm,meqn,mwaves,mbc,mx,
     &                  ql,qr,aux1,aux2,aux3,
     &                  imp,asdq,bmasdq,bpasdq)
c     =====================================================
      implicit double precision (a-h,o-z)
c
c     # Riemann solver in the transverse direction for 2D Burgers' equation
c     #  u_t + cos(theta)*(0.5*u^2)_x + sin(theta)*(0.5*u^2)_y = 0
c
c     # Split asdq into eigenvectors of Roe matrix B.
c     # For the scalar equation, this simply amounts to computing the
c     # transverse wave speed from the opposite Riemann problem.
c
      dimension    ql(1-mbc:maxm+mbc, meqn)
      dimension    qr(1-mbc:maxm+mbc, meqn)
      dimension   asdq(1-mbc:maxm+mbc, meqn)
      dimension bmasdq(1-mbc:maxm+mbc, meqn)
      dimension bpasdq(1-mbc:maxm+mbc, meqn)
      common /comrp/ theta
c
      if (ixy .eq. 1) then
          b = 0.5d0*dsin(theta)
        else
          b = 0.5d0*dcos(theta)
        endif
c
          do 10 i = 2-mbc, mx+mbc
             sb = b*(qr(i-1,1) + ql(i,1))
             bmasdq(i,1) = dmin1(sb, 0.d0) * asdq(i,1)
             bpasdq(i,1) = dmax1(sb, 0.d0) * asdq(i,1)
   10        continue
c
      return
      end


!##############################################################################
!# Tutorial 006j: Create a system matrix from a mass and a Laplace matrix
!##############################################################################

module tutorial006j

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use derivatives
  use spatialdiscretisation
  use linearsystemscalar
  use bilinearformevaluation
  use stdoperators

  use matrixio
  use ucd

  implicit none
  private

  public :: start_tutorial006j

contains

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

  subroutine start_tutorial006j

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialdiscretisation) :: rdiscretisation

    type(t_matrixScalar) :: rmatrixTemplate
    type(t_matrixScalar) :: rmatrixMass, rmatrixLaplace
    type(t_matrixScalar) :: rmatrix
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 006j")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rdiscretisation
    ! which describes the discretisation.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscretisation,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Create a CSR-matrix for the above
    ! discretisation.
    ! =================================

    ! Create the matrix structure
    call bilf_createMatrixStructure (rdiscretisation,LSYSSC_MATRIX9,rmatrixTemplate)

    ! =================================
    ! Derive a mass and a Laplace
    ! matrix which share the same
    ! structure but have their own
    ! content.
    ! =================================

    ! ------------------------------------
    ! ----- Mass matrix ------------------

    ! Share structure, allocate memory for new content
    call lsyssc_duplicateMatrix (rmatrixTemplate,rmatrixMass,&
        LSYSSC_DUP_SHARE, LSYSSC_DUP_EMPTY)

    ! Clear the matrix
    call lsyssc_clearMatrix (rmatrixMass)

    ! Create the matrix
    call stdop_assembleSimpleMatrix (rmatrixMass,DER_FUNC2D,DER_FUNC2D)

    ! ------------------------------------
    ! ----- Laplace matrix ---------------
    call lsyssc_duplicateMatrix (rmatrixTemplate,rmatrixLaplace,&
        LSYSSC_DUP_SHARE, LSYSSC_DUP_EMPTY)

    call lsyssc_clearMatrix (rmatrixLaplace)

    call stdop_assembleLaplaceMatrix (rmatrixLaplace)

    ! ------------------------------------
    ! ----- System matrix ----------------

    ! Share the structure, provide empty space for the content
    call lsyssc_duplicateMatrix (rmatrixTemplate,rmatrix,&
        LSYSSC_DUP_SHARE, LSYSSC_DUP_EMPTY)

    ! =================================
    ! Sum up Laplace and mass matrix.
    ! =================================

    ! We create the system as
    !
    !    rmatrix = 1/100 Mass + Laplace

    ! Clear the destination
    call lsyssc_clearMatrix (rmatrix)

    ! Incorporate (1/100) Mass to the system matrix:
    !    rmatrix = 1/100 Mass + rmatrix(=0)
    call lsyssc_matrixLinearComb (rmatrixMass,rmatrix,1.0_DP/100.0_DP,1.0_DP,&
        .false.,.false.,.true.,.true.)

    ! Incorporate Laplace to the system matrix
    !    rmatrix = Mass + rmatrix
    call lsyssc_matrixLinearComb (rmatrixMass,rmatrix,1.0_DP,1.0_DP,&
        .false.,.false.,.true.,.true.)

    ! =================================
    ! Write the matrix to a file.
    ! =================================
    call output_line ("Writing matrix to a text file...")

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006j_matrix.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006j_matrix.txt", "(E15.5)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the matrices
    call lsyssc_releaseMatrix (rmatrix)
    call lsyssc_releaseMatrix (rmatrixMass)
    call lsyssc_releaseMatrix (rmatrixLaplace)

    ! Release template matrix
    call lsyssc_releaseMatrix (rmatrixTemplate)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rdiscretisation)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


C
C $Id: ceezdp.f,v 1.3 2008-07-27 03:10:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding single precision routine.
C
      SUBROUTINE CEEZDP(DEL1,DEL2,SIGMA,C1,C2,C3,N)
      DOUBLE PRECISION DEL
      DOUBLE PRECISION DUMMY
      DOUBLE PRECISION COSHM1
      DOUBLE PRECISION COSHM2
      DOUBLE PRECISION DELP
      DOUBLE PRECISION DELM
      DOUBLE PRECISION SINHMP
      DOUBLE PRECISION SINHMM
      DOUBLE PRECISION DENOM
c
      DOUBLE PRECISION DEL1,DEL2,SIGMA,C1,C2,C3
c
c                                 coded by alan kaylor cline
c                           from fitpack -- january 26, 1987
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the coefficients c1, c2, and c3
c used to determine endpoint slopes. specifically, if
c function values y1, y2, and y3 are given at points x1, x2,
c and x3, respectively, the quantity c1*y1 + c2*y2 + c3*y3
c is the value of the derivative at x1 of a spline under
c tension (with tension factor sigma) passing through the
c three points and having third derivative equal to zero at
c x1. optionally, only two values, c1 and c2 are determined.
c
c on input--
c
c   del1 is x2-x1 (.gt. 0.).
c
c   del2 is x3-x1 (.gt. 0.). if n .eq. 2, this parameter is
c   ignored.
c
c   sigma is the tension factor.
c
c and
c
c   n is a switch indicating the number of coefficients to
c   be returned. if n .eq. 2 only two coefficients are
c   returned. otherwise all three are returned.
c
c on output--
c
c   c1, c2, and c3 contain the coefficients.
c
c none of the input parameters are altered.
c
c this subroutine references package module snhcsh.
c
c-----------------------------------------------------------
c
      IF (N.EQ.2) GO TO 2
      IF (SIGMA.NE.0.D0) GO TO 1
      DEL = DEL2 - DEL1
c
c tension .eq. 0.
c
      C1 = - (DEL1+DEL2)/ (DEL1*DEL2)
      C2 = DEL2/ (DEL1*DEL)
      C3 = -DEL1/ (DEL2*DEL)
      RETURN
c
c tension .ne. 0.
c
    1 CALL SNHCSHDP(DUMMY,COSHM1,SIGMA*DEL1,1)
      CALL SNHCSHDP(DUMMY,COSHM2,SIGMA*DEL2,1)
      DELP = SIGMA* (DEL2+DEL1)/2.D0
      DELM = SIGMA* (DEL2-DEL1)/2.D0
      CALL SNHCSHDP(SINHMP,DUMMY,DELP,-1)
      CALL SNHCSHDP(SINHMM,DUMMY,DELM,-1)
      DENOM = COSHM1* (DEL2-DEL1) - 2.D0*DEL1*DELP*DELM* (1.D0+SINHMP)*
     +        (1.D0+SINHMM)
      C1 = 2.D0*DELP*DELM* (1.D0+SINHMP)* (1.D0+SINHMM)/DENOM
      C2 = -COSHM2/DENOM
      C3 = COSHM1/DENOM
      RETURN
c
c two coefficients
c
    2 C1 = -1.D0/DEL1
      C2 = -C1
      RETURN
      END


c------------------------------------------------------------
c  This is the primary function here that does interpolation
c  by computing and applying a Jacobian transformation to warp
c  a set of 8 points into a standard set of coordinates (-1 to 1
c  in all three coordinate directions.  The routine computes
c  a vector valued function evaluated at each point given
c
c Arguments:
c xx - 3 vector defining point in space to evaluate result at
c coord = array holding actual coordinates of 8 corner points
c fun = return vector of 8 weights to interpolate result for
c      point x using actual values at corners defined by coord.
c
c  Author:  Kagan Tuncay with modifications by G Pavlis
c  Written:  Oct-DEc 2000
c  Modified:  December 2002 Original subroutine found in older
c  libgclgrid interpolated a function based on values passed
c  in.  This function returns the weights so that multiple
c  calls with no change in position can be recomputed faster.
c  Modification:  June 2008
c  Found serious problems with convergence of the loop here
c  when a point was located just outside a distorted box.
c  Repeated attempts to improve the lookup method to make this
c  go away failed.  The main thing this changed is that this
c  subroutine now returns and error code ierr.  0 means all is
c  fine while nonzero means the iteration in this routine
c  did not converge.  This is now used downstream in a recovery
c  using a different interpolation formula.
c------------------------------------------------------------

      subroutine fmeweights(xx,coord,fun,ierr)
      implicit none
      integer*4 ierr
      integer i,itno,j
      double precision x(3),xx(3),xdum
      double precision coord(8,3)
      double precision der(3,8),fun(8),jac(3,3)
      double precision residual(3),solution(3),er,det,jac1(3,3)
      integer MAXIT
      double precision CONVTEST
      parameter(MAXIT=20)
      parameter(CONVTEST=0.001)
      double precision scale

c  error flag set 0 as default
      ierr=0

c  We compute this scale in a bombproof way to make the code
c  independent of scale.  This is used in the convergence loop
c  below.  It is a little inefficient to do this, but safer
      scale = 0.0
      do j=2,8
            do i=1,3
                  scale = max(scale,abs(coord(j,i)-coord(j-1,i)))
            enddo
      enddo

      do i=1,3
         x(i)=0.
      enddo
      itno = 0

  100 continue
c
c     given x, derivatives of the interpolation functions with
c     respect to k1,k2,k3
c     der(i,j) -> i=1,3 j=1,8
c
      call fmlin3(der,3,fun,x)
c
c     matmul -> der x coord = jac
c
      CALL MATMUL(DER,3,COORD,8,JAC,3,3,8,3)
c
c     x=coord^T*F
c
      do i=1,3
         xdum=0.
         do j=1,8
            xdum=xdum+coord(j,i)*fun(j)
         enddo
         residual(i)=xdum
      enddo
c
c
c
      er=0.
      do i=1,3
         residual(i)=-(residual(i)-xx(i))
         er=er+residual(i)*residual(i)
      enddo
c
c     treex3 -> Jac^-1=Jac1
c
      CALL TREEX3(JAC,3,JAC1,3,DET)
c
c     mvmult -> matrix x vector
c     jac*residual = solution
c
      call MVMULT(JAC1,3,residual,3,3,solution)

      do i=1,3
         x(i)=x(i)+solution(i)
      enddo

      er = er/scale
      itno = itno + 1
c	write(*,*) itno, er
      if( (itno.lt.MAXIT) .and. (er.gt.CONVTEST)) goto 100
c  Set ierr nonzero if the loop above didn't converge
      if(itno.ge.MAXIT) ierr=1

      return
      end

      SUBROUTINE GEO(IP,XCOORD,GG,COORD,ICOORD,NELEM,IEL,
     +NF,INF)
C
C     STEERING VECTOR AND COORDINATES
C
      IMPLICIT NONE
      INTEGER INF,ICOORD,IEL
      DOUBLE PRECISION XCOORD(INF,*),COORD(ICOORD,*)
      INTEGER GG(24),NELEM(IEL,*),NF(*)
      INTEGER INC,I,J,IP

      INC=0
      DO 1 I=1,8
      INC=INC+1
      GG(INC)=NF(NELEM(IP,I))
 1    CONTINUE
      DO 2 I=1,8
      DO 2 J=1,3
      COORD(I,J)=XCOORD(NELEM(IP,I),J)
 2    CONTINUE
 5    FORMAT(24I3)
      RETURN
      END

      SUBROUTINE FMLIN3(DER,IDER,FUN,xsi1)
C
C      FORMS THE SHAPE FUNCTIONS AND THEIR
C      DERIVATIVES FOR 8-NODED BRICK ELEMENTS
C
      IMPLICIT NONE
      INTEGER IDER
      DOUBLE PRECISION DER(IDER,8),FUN(8)
      DOUBLE PRECISION ETA,XI,ZETA
      DOUBLE PRECISION ETAM,XIM,ZETAM
      DOUBLE PRECISION ETAP,XIP,ZETAP,xsi1(3)
      XI=xsi1(1)
      ETA=xsi1(2)
      ZETA=xsi1(3)
      ETAM=1.-ETA
      XIM=1.-XI
      ZETAM=1.-ZETA
      ETAP=ETA+1.
      XIP=XI+1.
      ZETAP=ZETA+1.
      FUN(1)=.125*XIM*ETAM*ZETAM
      FUN(2)=.125*XIM*ETAM*ZETAP
      FUN(3)=.125*XIP*ETAM*ZETAP
      FUN(4)=.125*XIP*ETAM*ZETAM
      FUN(5)=.125*XIM*ETAP*ZETAM
      FUN(6)=.125*XIM*ETAP*ZETAP
      FUN(7)=.125*XIP*ETAP*ZETAP
      FUN(8)=.125*XIP*ETAP*ZETAM
      DER(1,1)=-.125*ETAM*ZETAM
      DER(1,2)=-.125*ETAM*ZETAP
      DER(1,3)=.125*ETAM*ZETAP
      DER(1,4)=.125*ETAM*ZETAM
      DER(1,5)=-.125*ETAP*ZETAM
      DER(1,6)=-.125*ETAP*ZETAP
      DER(1,7)=.125*ETAP*ZETAP
      DER(1,8)=.125*ETAP*ZETAM
      DER(2,1)=-.125*XIM*ZETAM
      DER(2,2)=-.125*XIM*ZETAP
      DER(2,3)=-.125*XIP*ZETAP
      DER(2,4)=-.125*XIP*ZETAM
      DER(2,5)=.125*XIM*ZETAM
      DER(2,6)=.125*XIM*ZETAP
      DER(2,7)=.125*XIP*ZETAP
      DER(2,8)=.125*XIP*ZETAM
      DER(3,1)=-.125*XIM*ETAM
      DER(3,2)=.125*XIM*ETAM
      DER(3,3)=.125*XIP*ETAM
      DER(3,4)=-.125*XIP*ETAM
      DER(3,5)=-.125*XIM*ETAP
      DER(3,6)=.125*XIM*ETAP
      DER(3,7)=.125*XIP*ETAP
      DER(3,8)=-.125*XIP*ETAP
      RETURN
      END

      SUBROUTINE TREEX3(JAC,IJAC,JAC1,IJAC1,DET)
C
C      FORMS THE INVERSE OF A 3 BY 3 MATRIX
C
      IMPLICIT NONE
      INTEGER IJAC,IJAC1
      DOUBLE PRECISION JAC(IJAC,*),JAC1(IJAC1,*)
      INTEGER K,L
      DOUBLE PRECISION DET

      DET=JAC(1,1)*(JAC(2,2)*JAC(3,3)-JAC(3,2)*JAC(2,3))
      DET=DET-JAC(1,2)*(JAC(2,1)*JAC(3,3)-JAC(3,1)*JAC(2,3))
      DET=DET+JAC(1,3)*(JAC(2,1)*JAC(3,2)-JAC(3,1)*JAC(2,2))
      JAC1(1,1)=JAC(2,2)*JAC(3,3)-JAC(3,2)*JAC(2,3)
      JAC1(2,1)=-JAC(2,1)*JAC(3,3)+JAC(3,1)*JAC(2,3)
      JAC1(3,1)=JAC(2,1)*JAC(3,2)-JAC(3,1)*JAC(2,2)
      JAC1(1,2)=-JAC(1,2)*JAC(3,3)+JAC(3,2)*JAC(1,3)
      JAC1(2,2)=JAC(1,1)*JAC(3,3)-JAC(3,1)*JAC(1,3)
      JAC1(3,2)=-JAC(1,1)*JAC(3,2)+JAC(3,1)*JAC(1,2)
      JAC1(1,3)=JAC(1,2)*JAC(2,3)-JAC(2,2)*JAC(1,3)
      JAC1(2,3)=-JAC(1,1)*JAC(2,3)+JAC(2,1)*JAC(1,3)
      JAC1(3,3)=JAC(1,1)*JAC(2,2)-JAC(2,1)*JAC(1,2)
      DO 1 K=1,3
      DO 1 L=1,3
      JAC1(K,L)=JAC1(K,L)/DET
    1 CONTINUE
      RETURN
      END

      SUBROUTINE READELR(NX,NY,NZ,iel,NELEM)
C
C     FOR A DOMAIN WITH NX, NY, AND NZ IN X Y AND Z DIR.
C
      IMPLICIT NONE
      INTEGER IEL
      INTEGER N(8),NELEM(IEL,*)
      INTEGER NX,NY,NZ,nnn
      INTEGER II,I,K,J

      DO K=1,NZ
         DO J=1,NY
            DO  I=1,NX
               N(1)=(K-1)*(NX+1)*(NY+1)+(J-1)*(NX+1)+I
               N(2)=N(1)+(NX+1)*(NY+1)
               N(3)=N(2)+1
               N(4)=N(1)+1
               N(5)=N(1)+(NX+1)
               N(6)=N(5)+(NX+1)*(NY+1)
               N(7)=N(6)+1
               N(8)=N(5)+1
               NNN=NNN+1
               DO II=1,8
                  NELEM(NNN,II)=N(II)
               enddo
            enddo
         enddo
      enddo

      RETURN
      END

      SUBROUTINE MATMUL(A,IA,B,IB,C,IC,L,M,N)
C
C      FORMS THE PRODUCT OF TWO MATRICES
C
      IMPLICIT NONE
      INTEGER IA,IB,IC
      DOUBLE PRECISION  A(IA,*),B(IB,*),C(IC,*)
      INTEGER L,M,N,I,J,K
      DOUBLE PRECISION X

      DO 1 I=1,L
      DO 1 J=1,N
      X=0.0
      DO 2 K=1,M
    2 X=X+A(I,K)*B(K,J)
      C(I,J)=X
    1 CONTINUE
      RETURN
      END

      SUBROUTINE MATRAN(A,IA,B,IB,M,N)
C
C      FORMS THE TRANSPOSE OF A MATRIX
C
      IMPLICIT NONE
      INTEGER IA,IB
      DOUBLE PRECISION A(IA,*),B(IB,*)
      INTEGER M,N,I,J

      DO 1 I=1,M
      DO 1 J=1,N
    1 A(J,I)=B(I,J)
      RETURN
      END

      SUBROUTINE MVMULT(M,IM,V,K,L,Y)
C
C      MULTIPLIES A MATRIX BY A VECTOR
C
      IMPLICIT NONE
      INTEGER IM
      DOUBLE PRECISION M(IM,*),V(*),Y(*)
      INTEGER K,L,I,J
      DOUBLE PRECISION X

      DO 1 I=1,K
      X=0.
      DO 2 J=1,L
    2 X=X+M(I,J)*V(J)
      Y(I)=X
    1 CONTINUE
      RETURN
      END


      double complex function L34_12(j1,j2,j3,j4,j5,j6,za,zb)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6
      integer i1,i2,i3,i4
      double complex z2,bit1,bit2

      double precision t,t134,t234,del3,del12,del56

      z2(i1,i2,i3,i4)=za(i1,i2)*zb(i2,i4)+za(i1,i3)*zb(i3,i4)

      t134=t(j1,j3,j4)
      t234=t(j2,j3,j4)
      del12=s(j1,j2)-s(j3,j4)-s(j5,j6)
      del56=s(j5,j6)-s(j1,j2)-s(j3,j4)
      Del3=s(j1,j2)**2+s(j3,j4)**2+s(j5,j6)**2
     . -2d0*(s(j1,j2)*s(j3,j4)+s(j1,j2)*s(j5,j6)+s(j3,j4)*s(j5,j6))

      bit1=
     . +zb(j4,j1)*za(j1,j3)*zb(j3,j5)+zb(j4,j2)*za(j2,j3)*zb(j3,j5)
     . +zb(j4,j1)*za(j1,j4)*zb(j4,j5)+zb(j4,j2)*za(j2,j4)*zb(j4,j5)
      bit2=
     . +zb(j4,j5)*za(j5,j1)*zb(j1,j5)+zb(j4,j6)*za(j6,j1)*zb(j1,j5)
     . +zb(j4,j5)*za(j5,j2)*zb(j2,j5)+zb(j4,j6)*za(j6,j2)*zb(j2,j5)

c-----first line
      L34_12=1.5d0*del56*(t134-t234)*z2(j3,j1,j2,j4)*z2(j6,j1,j2,j5)
     . /(z2(j2,j5,j6,j1)*Del3**2)
      L34_12=L34_12+1.5d0*za(j3,j6)*bit1/(z2(j2,j5,j6,j1)*Del3)

c----second line
      L34_12=L34_12+0.5d0*za(j3,j4)*zb(j4,j5)*bit2
     . /(zb(j5,j6)*z2(j2,j5,j6,j1)*del3)
      L34_12=L34_12+zb(j1,j4)*za(j2,j6)*t134
     . *(za(j3,j6)*del12-2d0*za(j3,j4)*zb(j4,j5)*za(j5,j6))
     . /(za(j5,j6)*z2(j2,j5,j6,j1)**2*del3)

c-----third line
      L34_12=L34_12+0.5d0*t134/(z2(j2,j5,j6,j1)*del3)
     . *( +za(j3,j4)*zb(j4,j5)**2/zb(j5,j6)
     .    +zb(j3,j4)*za(j3,j6)**2/za(j5,j6)-2d0*za(j3,j6)*zb(j4,j5))

c--line before penultimate line
      L34_12=L34_12
     . +(+z2(j3,j1,j4,j5)/zb(j5,j6)
     .   -za(j3,j4)*zb(j1,j4)*za(j2,j6)/z2(j2,j5,j6,j1))
     .  *(zb(j4,j5)*del12
     .  -2d0*zb(j4,j3)*za(j3,j6)*zb(j6,j5))/(z2(j2,j5,j6,j1)*Del3)

c--penultimate line
      L34_12=L34_12+4d0
     . *(za(j3,j4)*zb(j4,j5)*z2(j6,j1,j3,j4)
     .  +za(j6,j3)*zb(j3,j4)*z2(j3,j2,j4,j5))/(z2(j2,j5,j6,j1)*Del3)

c--last line
      L34_12=L34_12+2d0*del12/(z2(j2,j5,j6,j1)*Del3)
     . *(+zb(j4,j5)*z2(j3,j2,j4,j5)/zb(j5,j6)
     .   -za(j3,j6)*z2(j6,j1,j3,j4)/za(j5,j6))

      return
      end


      subroutine makeggt(g,n1dim,nrow,ncol,wk)
c----------------------------------------------------------------------
c       makeggt forms the inner product matrix of backus-gilbert
c  inversion.  this version is a space economizer in that the inner
c  product matrix overwrites the input matrix of discretized kernels.
c
c  arguments-
c
c     g-n1dim by ncol array.
c       on input g contains the discretized kernels function in it's
c       columns.  on output g will contain the inner product matrix
c       obtained from these functions (g will be ncol x ncol on output)
c     n1dim-first dimension of g in calling program
c           (note n1dim must be .ge. ncol)
c     nrow-number of rows in g on input.
c     ncol-number of columns in g
c          (g will returned as a ncol x ncol matrix)
c     wk-vector work area of length at least nrow
c
c  this routine utilizes the bla subroutines.
c----------------------------------------------------------------------
      dimension g(n1dim,ncol),wk(nrow)
      data inc/1/
      do 150 j=1,ncol
           call scopy(nrow,g(1,j),inc,wk,inc)
           g(j,j)=dsdot(nrow,wk,inc,wk,inc)
           if(j.ne.ncol) then
                do 100 i=j+1,ncol
  100                g(i,j)=dsdot(nrow,wk,inc,g(1,i),inc)
           endif
  150 continue
      do 200 j=1,ncol-1
           do 200 i=j+1,ncol
  200           g(j,i)=g(i,j)
      return
      end

c $Id$


SUBROUTINE p45(input_file,output_file)
!-------------------------------------------------------------------------
! Program 4.5 Analysis of elasto-plastic beams or rigid-jointed frames
!             using 2-node beam or beam/rod elements in 1-, 2- or
!             3-dimensions
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,incs,iters,iy,k,limit,loaded_nodes,ndim,ndof,nels,neq,    &
   nod=2,nodof,nn,nprops,np_types,nr,nlen
 REAL(iwp)::tol,total_load,zero=0.0_iwp
 LOGICAL::converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
  node(:),num(:)
 REAL(iwp),ALLOCATABLE::action(:),bdylds(:),coord(:,:),dload(:),eld(:),   &
   eldtot(:),gamma(:),g_coord(:,:),holdr(:,:),km(:,:),kv(:),loads(:),     &
   oldis(:),prop(:,:),react(:),val(:,:)
 CHARACTER(LEN=15)::argv
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,nn,ndim,nprops,np_types
 IF(ndim==1)nodof=2
 IF(ndim==2)nodof=3
 IF(ndim==3)nodof=6
 ndof=nod*nodof
 ALLOCATE(nf(nodof,nn),km(ndof,ndof),coord(nod,ndim),g_coord(ndim,nn),    &
   eld(ndof),action(ndof),g_num(nod,nels),num(nod),g(ndof),gamma(nels),   &
   g_g(ndof,nels),holdr(ndof,nels),react(ndof),prop(nprops,np_types),     &
   etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 IF(ndim==3)READ(10,*)gamma
 READ(10,*)g_coord
 READ(10,*)g_num
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq),eldtot(0:neq),bdylds(0:neq),oldis(0:neq))
!-----------------------loop the elements to find global array sizes------
 kdiag=0
 elements_1: DO iel=1,nels
   num=g_num(:,iel)
   CALL num_to_g(num,nf,g)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 holdr=zero
!-----------------------global stiffness matrix assembly------------------
 kv=zero
 elements_2: DO iel=1,nels
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   CALL rigid_jointed(km,prop,gamma,etype,iel,coord)
   g=g_g(:,iel)
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
 READ(10,*)loaded_nodes
 ALLOCATE(node(loaded_nodes),val(loaded_nodes,nodof))
 READ(10,*)(node(i),val(i,:),i=1,loaded_nodes)
 READ(10,*)limit,tol,incs
 ALLOCATE(dload(incs))
 READ(10,*)dload
!-----------------------equation factorisation----------------------------
 CALL sparin(kv,kdiag)
!-----------------------load increment loop-------------------------------
 total_load=zero
 eldtot=zero
 load_incs: DO iy=1,incs
   total_load=total_load+dload(iy)
   WRITE(*,'(/,A,I5)')" load step",iy
   WRITE(11,'(/A,I3,A,E12.4)')" Load step",iy,"    Load factor ",total_load
   oldis=zero
   bdylds=zero
   iters=0
   its: DO
     iters=iters+1
     WRITE(*,*)"iteration no",iters
     loads=zero
     DO i=1,loaded_nodes
       loads(nf(:,node(i)))=dload(iy)*val(i,:)
     END DO
     loads=loads+bdylds
     bdylds=zero
!-----------------------forward/back-substitution-------------------------
     CALL spabac(kv,loads,kdiag)
     loads(0)=zero
!-----------------------check convergence---------------------------------
     CALL checon(loads,oldis,tol,converged)
!-----------------------inspect moments in all elements-------------------
     elements_3: DO iel=1,nels
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       g=g_g(:,iel)
       eld=loads(g)
       CALL rigid_jointed(km,prop,gamma,etype,iel,coord)
       action=MATMUL(km,eld)
       react=zero
!------------------if plastic moments exceeded generate correction vector-
       IF(limit/=1)THEN
         CALL hinge(coord,holdr,action,react,prop,iel,etype,gamma)
         bdylds(g)=bdylds(g)-react
         bdylds(0)=zero
       END IF
!-----------------------at convergence update element reactions-----------
       IF(iters==limit.OR.converged)                                      &
         holdr(:,iel)=holdr(:,iel)+react(:)+action(:)
     END DO elements_3
     IF(iters==limit.OR.converged)EXIT its
   END DO its
   eldtot=loads+eldtot
   WRITE(11,'(A)')  "  Node   Displacement(s) and Rotation(s)"
   DO i=1,loaded_nodes
     WRITE(11,'(I5,6E12.4)')node(i),eldtot(nf(:,node(i)))
   END DO
   WRITE(11,'(A,I5,A)')" Converged in",iters," iterations"
   IF(iters==limit.AND.limit/=1)EXIT load_incs
 END DO load_incs
END SUBROUTINE p45


      SUBROUTINE MC01PD( K, REZ, IMZ, P, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the coefficients of a real polynomial P(x) from its
C     zeros.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     K       (input) INTEGER
C             The number of zeros (and hence the degree) of P(x).
C             K >= 0.
C
C     REZ     (input) DOUBLE PRECISION array, dimension (K)
C     IMZ     (input) DOUBLE PRECISION array, dimension (K)
C             The real and imaginary parts of the i-th zero of P(x)
C             must be stored in REZ(i) and IMZ(i), respectively, where
C             i = 1, 2, ..., K. The zeros may be supplied in any order,
C             except that complex conjugate zeros must appear
C             consecutively.
C
C     P       (output) DOUBLE PRECISION array, dimension (K+1)
C             This array contains the coefficients of P(x) in increasing
C             powers of x. If K = 0, then P(1) is set to one.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (K+1)
C             If K = 0, this array is not referenced.
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             > 0:  if INFO = i, (REZ(i),IMZ(i)) is a complex zero but
C                   (REZ(i-1),IMZ(i-1)) is not its conjugate.
C
C     METHOD
C
C     The routine computes the coefficients of the real K-th degree
C     polynomial P(x) as
C
C        P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K))
C
C     where r(i) = (REZ(i),IMZ(i)).
C
C     Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j)
C     form a complex conjugate pair (where i <> j), and that IMZ(i) = 0
C     if r(i) is real.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01DD by A.J. Geurts.
C
C     REVISIONS
C
C     V. Sima, May 2002.
C
C     KEYWORDS
C
C     Elementary polynomial operations, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, K
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), IMZ(*), P(*), REZ(*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  U, V
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, XERBLA
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      IF( K.LT.0 ) THEN
         INFO = -1
C
C        Error return.
C
         CALL XERBLA( 'MC01PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      INFO = 0
      P(1) = ONE
      IF ( K.EQ.0 )
     $   RETURN
C
      I = 1
C     WHILE ( I <= K ) DO
   20 IF ( I.LE.K ) THEN
         U = REZ(I)
         V = IMZ(I)
         DWORK(1) = ZERO
C
         IF ( V.EQ.ZERO ) THEN
            CALL DCOPY( I, P, 1, DWORK(2), 1 )
            CALL DAXPY( I, -U, P, 1, DWORK, 1 )
            I = I + 1
C
         ELSE
            IF ( I.EQ.K ) THEN
               INFO = K
               RETURN
            ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN
               INFO = I + 1
               RETURN
            END IF
C
            DWORK(2) = ZERO
            CALL DCOPY( I, P, 1, DWORK(3), 1 )
            CALL DAXPY( I, -(U + U),  P, 1, DWORK(2), 1 )
            CALL DAXPY( I, U**2+V**2, P, 1, DWORK, 1 )
            I = I + 2
         END IF
C
         CALL DCOPY( I, DWORK, 1, P, 1 )
         GO TO 20
      END IF
C     END WHILE 20
C
      RETURN
C *** Last line of MC01PD ***
      END