program fd3d
    use nvtx
    use openacc
    use mpi
    use derivative_mod_gpu

    implicit none
    integer, parameter  :: dp = kind(1.d0)
    real(dp), parameter :: two_pi = 8.d0 * atan(1.d0)

    integer  :: n(3), num_iters, block_size(3), itime, local_n3
    real(dp) :: length, dl, dl_inv
    real(dp) :: factors(5)
    real(dp) :: timer(2)
    real(dp), dimension(:, :, :), allocatable :: u, du, du_exact
    integer :: ierr, mpi_rank, mpi_procs

    call mpi_init(ierr)
    call mpi_comm_rank(mpi_comm_world, mpi_rank,ierr)
    call mpi_comm_size(mpi_comm_world, mpi_procs, ierr)

    call box_init('der3d.nml')
    call allocate_arrays()
    call initial_condition()
    call set_factors()

   ! #ifdef OPENACC
    call acc_set_device_num(mpi_rank,acc_device_nvidia)
   ! #endif

    !$acc data copy(u,du,n,factors)

    write(*,*) "Loop begins"
    call cpu_time(timer(1))
    do itime = 0, num_iters
        call nvtxStartRange("MPI")
        call synchronize_gpu_state()
        call nvtxEndRange
        call nvtxStartRange("Derivative")
!!        call derivative()
        call derivative_halo_gpu_dev(u,du,n(1),n(2),local_n3,factors)
        call nvtxEndRange
        call mpi_barrier(mpi_comm_world,ierr)
    end do
    call cpu_time(timer(2))
    write(*,*) "Loop ends"
    !$acc end data

    write (*, *) 'time taken :', timer(2) - timer(1), 'error :', maxval(du_exact - du(1:n(1), 1:n(2), 1:local_n3))

contains

    subroutine box_init(filename)
        character(*), intent(in) :: filename
        namelist /box_nml/ n, length, num_iters

        open (unit=10, file=filename, status='old')
        read (10, nml=box_nml)
        close (10)

        local_n3 = n(3)/mpi_procs;
        length = length * two_pi
        dl = length / n(1)
        dl_inv = 1.d0 / dl
    end subroutine box_init

    subroutine set_factors()
        factors = dl_inv * (1.d0 / 12.d0)*[1, -8, 0, 8, -1]
    end subroutine set_factors

    subroutine allocate_arrays()
        allocate (u(-1:n(1) + 2, -1:n(2) + 2, -1:local_n3 + 2))
        allocate (du(n(1), n(2), local_n3))
        allocate (du_exact(n(1), n(2), local_n3))

        u = 0.d0
        du = 0.d0
        du_exact = 0.d0
    end subroutine allocate_arrays

    subroutine initial_condition()
        integer  :: i, j, k
        real(dp) :: x, y, z

        u(:, :, :) = 0.d0
        du_exact(:, :, :) = 0.d0

        do k = 1, local_n3
            z = dl * (k - 1 + local_n3*mpi_rank)
            do j = 1, n(2)
                y = dl * (j - 1)
                do i = 1, n(1)
                    x = dl * (i - 1)
                    u(i, j, k) = sin(x) + sin(y) + sin(z)
                end do
            end do
        end do

        do k = 1, local_n3
            z = dl * (k - 1 + local_n3*mpi_rank)
            do j = 1, n(2)
                y = dl * (j - 1)
                do i = 1, n(1)
                    x = dl * (i - 1)
                    du_exact(i, j, k) = cos(x) + cos(y) + cos(z)
                end do
            end do
        end do
    end subroutine initial_condition

    subroutine derivative()
        integer  :: i, j, k
        !$acc parallel loop collapse(3) present(u,du,n,factors)
        do k = 1, local_n3
            do j = 1, n(2)
                do i = 1, n(1)
                    du(i, j, k) = (u(i - 2, j, k) + u(i, j - 2, k) + u(i, j, k - 2)) * factors(1) + &
                        (u(i - 1, j, k) + u(i, j - 1, k) + u(i, j, k - 1)) * factors(2) + &
                        (u(i, j, k) + u(i, j, k) + u(i, j, k)) * factors(3) + &
                        (u(i + 1, j, k) + u(i, j + 1, k) + u(i, j, k + 1)) * factors(4) + &
                        (u(i + 2, j, k) + u(i, j + 2, k) + u(i, j, k + 2)) * factors(5)
                end do
            end do
        end do
        !$acc end parallel
    end subroutine derivative

    subroutine synchronize_gpu_state()
        integer :: i,j,k
        integer :: data_size, right, left, mpi_error_flag
        integer :: mpi_status_flag(mpi_status_size)

        !! Periodic Boundary Setup
        !! X-direction

        !$acc parallel loop collapse(3)  present(u)
        do k=1,local_n3
        do j=1,n(2)
!!        !$acc loop independent
        do i=-1,0
        u(i,j,k)      = u(n(1)+i,j,k)
        u(n(1)+i+2,j,k) = u(i+2,j,k)
        enddo
        enddo
        enddo
        !$acc end parallel

        !! Y-direction
        !$acc parallel loop collapse(3) present(u)
        do k=1,local_n3
        do j=-1,0
!!        !$acc loop independent
        do i=1,n(1)
        u(i,j,k)      = u(i,n(2)+j,k)
        u(i,n(2)+j+2,k) = u(i,j+2,k)
         enddo
         enddo
         enddo
        !$acc end parallel

        !! Z-Direction Synchronisation, If only 1 process, no point using mpi.

        data_size = 2*((n(1)+4)*(n(2)+4))

        !! if (mpi_procs ==1) then
        !!     u(:,:,0)          = u(:,:,local_n3)
        !!     u(:,:,-1)         = u(:,:,local_n3-1)

        !!     u(:,:,local_n3+1) = u(:,:,1)
        !!     u(:,:,local_n3+2) = u(:,:,2)

        !! else

        if (mpi_rank == mpi_procs - 1) then
              right = 0
        else
             right = mpi_rank+1
        end if
        if (mpi_rank == 0) then
              left = mpi_procs - 1
        else
              left = mpi_rank - 1
        end if

        !$acc host_data use_device( u )

        !! Send right boundary elements to next processor, and recieve the same from previous.
        call MPI_SENDRECV(u(-1,-1,local_n3-1),data_size,MPI_DOUBLE_PRECISION,right,0,&
            u(-1,-1,-1),data_size,MPI_DOUBLE_PRECISION,left,0,MPI_COMM_WORLD,mpi_status_flag,mpi_error_flag)

        !! Send left boundary elements to previous processor, which stores it at left.
        call MPI_SENDRECV(u(-1,-1,1),data_size,MPI_DOUBLE_PRECISION,left,1,&
            u(-1,-1,local_n3+1),data_size,MPI_DOUBLE_PRECISION,right,1,MPI_COMM_WORLD,mpi_status_flag,mpi_error_flag)
        !! endif
        !$acc end host_data
    end subroutine synchronize_gpu_state

end program fd3d


!! R456 component-spec
!   is [ keyword = ] component-data-source

13 type person
   integer age
   character (LEN = 50) name
14 END TYPE person

type point                            ! A base type
  REAL :: X, Y
END TYPE POINT
TYPE, EXTENDS(POINT) :: COLOR_POINT   ! An extension of TYPE(POINT)
  ! Components X and Y, and component name POINT, inherited from parent
  INTEGER :: COLOR
END TYPE COLOR_POINT

type(person) p

!! NOTE 4.59
!
15 type(point) :: PV = POINT(1.0, 2.0)
type(color_point) :: cp1, cp2, cp3

cp1 = COLOR_POINT( point=point(1,2), color=3)
cp2 = COLOR_POINT( point=PV, color=3)
cp3 = COLOR_POINT(1 , 2, 3)

!! NOTE 4.60
!
16 p = PERSON (21, 'JOHN SMITH')
! This could also be written as
p = PERSON (NAME = 'JOHN SMITH', AGE = 21)

end


! { dg-do run }
! verifies basic functioning of the ishft and ishftc intrinsics
if (ishft (1_1, 0) /= 1) STOP 1
if (ishft (1_1, 1) /= 2) STOP 2
if (ishft (3_1, 1) /= 6) STOP 3
if (ishft (-1_1, 1) /= -2) STOP 4
if (ishft (-1_1, -1) /= 127) STOP 5
if (ishft (96_1, 2) /= -128) STOP 6

if (ishft (1_2, 0) /= 1) STOP 7
if (ishft (1_2, 1) /= 2) STOP 8
if (ishft (3_2, 1) /= 6) STOP 9
if (ishft (-1_2, 1) /= -2) STOP 10
if (ishft (-1_2, -1) /= 32767) STOP 11
if (ishft (16384_2 + 8192_2, 2) /= -32768_4) STOP 12

if (ishft (1_4, 0) /= 1) STOP 13
if (ishft (1_4, 1) /= 2) STOP 14
if (ishft (3_4, 1) /= 6) STOP 15
if (ishft (-1_4, 1) /= -2) STOP 16
if (ishft (-1_4, -1) /= 2147483647) STOP 17
if (ishft (1073741824_4 + 536870912_4, 2) /= -2147483648_8) STOP 18

if (ishft (1_8, 0) /= 1) STOP 19
if (ishft (1_8, 1) /= 2) STOP 20
if (ishft (3_8, 1) /= 6) STOP 21
if (ishft (-1_8, 1) /= -2) STOP 22
if (ishft (-1_8, -60) /= z'F') STOP 23

if (ishftc (1_1, 0) /= 1) STOP 24
if (ishftc (1_1, 1) /= 2) STOP 25
if (ishftc (3_1, 1) /= 6) STOP 26
if (ishftc (-1_1, 1) /= -1) STOP 27
if (ishftc (-1_1, -1) /= -1) STOP 28
if (ishftc (ishftc (96_1, 2), -2) /= 96) STOP 29

if (ishftc (1_2, 0) /= 1) STOP 30
if (ishftc (1_2, 1) /= 2) STOP 31
if (ishftc (3_2, 1) /= 6) STOP 32
if (ishftc (-1_2, 1) /= -1) STOP 33
if (ishftc (-1_2, -1) /= -1) STOP 34
if (ishftc (ishftc (25000_2, 2), -2) /= 25000) STOP 35

if (ishftc (1_4, 0) /= 1) STOP 36
if (ishftc (1_4, 1) /= 2) STOP 37
if (ishftc (3_4, 1) /= 6) STOP 38
if (ishftc (-1_4, 1) /= -1) STOP 39
if (ishftc (-1_4, -1) /= -1) STOP 40
if (ishftc (ishftc (1325876_4, 2), -2) /= 1325876) STOP 41

if (ishftc (1_8, 0) /= 1) STOP 42
if (ishftc (1_8, 1) /= 2) STOP 43
if (ishftc (3_8, 1) /= 6) STOP 44
if (ishftc (-1_8, 1) /= -1) STOP 45
if (ishftc (-1_8, -1) /= -1) STOP 46
if (ishftc (ishftc (1325876_8, 2), -2) /= 1325876) STOP 47
end


== Checks if given `array` is empty.
==
== Returns: Boolean
==     True if `array` is empty, false otherwise.
empty (array) -> array = []

== Counts the number of elements in the array.
==
== Returns: Number
length (array) -> empty (array) ? 0 : 1 + length (array[1...])

== Checks if given `index` is within the bounds of given `array`.
==
== Returns: Boolean
==     True if the index is in range (-len + 1; len), false otherwise.
in bounds (array, index) {
    len << length (array)
} ->
    index = -len + 2 .. len


        SUBROUTINE ZCLRIP(PASS,CCR9,CCRA,GRAT,CARPOS,ORDER,MINRIP,
     *                  NS,NSPEC,FLUX,ERR,EPS,ISTAT)
*
*  Module number:
*
*  Module name: zclrip
*
*  Keyphrase:
*  ----------
*       GHRS echelle ripple routine
*
*  Description:
*  ------------
*       This routine performs the echelle ripple removal by dividing
*       the flux by the echelle ripple function given by:
*
*               ripple = gnorm * sinc(a*x+b)**2
*
*       where:
*                        cos(theta+beta+delta)
*               gnorm = -----------------------
*                       cos(theta+beta-delta+e)
*
*                            cos(theta+beta+delta)*sin(theta+e/2)
*               x = pi * m * ------------------------------------
*                                   sin(theta+beta+e/2)
*
*               e = arctan ( (samp-280.0)/f )
*               samp = the photocathode sample position
*               theta = (r0 - carpos)*2*pi/65536.0
*               r0,beta,delta,f are grating parameters in table CCRA
*               a and b are coefficients from table CCR9
*
*	The ripple function is normalized to 1. at carrousel position
*	27492 for ECH-A and 39144 for ECH-B at the center of the
*	photocathode (e=0)
*
*  FORTRAN name: zclrip
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*       none
*  Subroutines Called:
*  -------------------
*  CDBS:
*       zrccra, zrccr9
*  SDAS:
*       ZMSPUT
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       May 89  D. Lindler      Designed and coded
*      1.1      Sep 91  S. Hulbert      Normalize ripple function, implemented
*					PASS flag
*      1.2      Nov 96  M. De La Pena   Added STPTIM to HRSDEF
*-------------------------------------------------------------------------------
* INPUTS:
*       pass - integer flag set to 1 on first call, -1 on last
*       ccr9 - interpolated echelle ripple coef. table
*       ccra - echelle ripple grating parameter table
*       grat - grating mode
*       carpos - carrousel position
*       order - spectral order
*       minrip - minimum ripple value to apply
*       ns - number of points in each spectra
*       nspec - number of spectra
*
* INPUT/OUTPUTS:
*       flux - flux array (nsxnspec)
*       err - propagated statistical error array
*       eps - epsilon array
*
* OUTPUT:
*       istat - error status
*
*----------------------------------------------------------------------------
        INTEGER PASS
        CHARACTER*64 CCRA,CCR9
        CHARACTER*5 GRAT
        INTEGER CARPOS,ORDER,NS,NSPEC,ISTAT
        REAL FLUX(NS,NSPEC),ERR(NS,NSPEC),EPS(NS,NSPEC),MINRIP
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C HRS epsilons
C
        INTEGER EPSFIL
        PARAMETER (EPSFIL = 800)
C
C                       /HRSDEF/
C Deflection pattern common block
C       NBINS - Number of supstep bins
C       NINIT - number of initial deflection pairs
C       IXDEF(5) - initial x-deflections
C       XDEF(7) - x-deflections for each bin
C       YDEF(7) - y-deflections for each bin
C       RCODES(7) - repeat codes for each bin
C       BINIDS(7) - substep bins ids for each bin
C       SAMPLE(7) - starting sample position for each spectra
C       LINE(7) - starting line position for each spectra
C       DELTAS(7) - sample position increment for each spectra
C       HOFF(7),VOFF(7) - horizontal and vertical offsets
C       DOPMAG, DOPZER - dopler magnitude and zero time
C       XDCAL, XDCALP - x-deflection calibration parameters
C       STPTIM - integration time at each step pattern position
C
        INTEGER NBINS,NINIT,IXDEF(5),XDEF(7),YDEF(7),RCODES(7)
        INTEGER BINIDS(7),HOFF(7),VOFF(7)
        REAL SAMPLE(7),LINE(7),DELTAS(7),DOPMAG,XDCAL,XDCALP
        DOUBLE PRECISION DOPZER,STPTIM
        COMMON /HRSDEF/ DOPZER,STPTIM,NBINS,NINIT,IXDEF,XDEF,YDEF,
     *                  RCODES,BINIDS,SAMPLE,LINE,DELTAS,HOFF,VOFF,
     *                  DOPMAG,XDCAL,XDCALP
C
C local variables
C
        INTEGER FIRST
        PARAMETER (FIRST = 1)
        INTEGER LAST
        PARAMETER (LAST = -1)
C
        INTEGER I,ISPEC,CLAST
        REAL X,E,PI,F,BETA,THETA,DELTA,R0,COEF(2),TBD,TB,SINC2
        REAL COSTBD,E2,TBMD,R,S,DS
	REAL CPNORM, RNORM
        CHARACTER*80 CONTXT
        DATA PI/3.14159/
C
C--------------------------------------------------------------------------
C
C If first call read table ccra
C
        IF((GRAT.NE.'ECH-A').AND.(GRAT.NE.'ECH-B'))GO TO 900
        IF(PASS.EQ.FIRST)THEN
           CALL ZRCCRA(CCRA,GRAT,F,BETA,DELTA,R0,CPNORM,ISTAT)
           IF(ISTAT.NE.0)GO TO 999
           WRITE(CONTXT,99)GRAT,R0
 99        FORMAT('Echelle Ripple grating parameters for ',A5,
     *          '   R0=',F10.1)
           CALL ZMSPUT(CONTXT,STDOUT,0,ISTAT)
           WRITE(CONTXT,199)BETA,DELTA,F
 199       FORMAT(' beta=',F8.3,'   delta=',F8.3,'   F=',G14.6)
           CALL ZMSPUT(CONTXT,STDOUT,0,ISTAT)
C
C convert angles to radians, focal length to sample units
C
           BETA = BETA * PI/180.0
           DELTA = DELTA * PI/180.0
           F = F/0.05
           CLAST=-1
        ENDIF
C
C If new carrousel position, get new A,B coefficients
C
        IF(CARPOS.NE.CLAST)THEN
           CALL ZRCCR9(PASS,CCR9,GRAT,ORDER,CARPOS,COEF,ISTAT)
           IF(ISTAT.NE.0)GO TO 999
           WRITE(CONTXT,299)CARPOS,COEF
 299       FORMAT('Echelle ripple coef. for carpos=',I7,
     *          '   A=',F10.6,'   B=',F10.6)
           CALL ZMSPUT(CONTXT,STDOUT,0,ISTAT)
C
C calculate normalization factor for ripple fuction at the CPCENT carrousel
C position with E=0 (i.e. at the center of the photocathode)
C
           THETA = (R0-CPNORM)*2*PI/65536.0 - BETA
           TB = THETA+BETA
           TBD = TB + DELTA
           TBMD = TB - DELTA
           COSTBD = COS(TBD)
           X = PI*ORDER*COSTBD*SIN(THETA)/SIN(TB)
           X = COEF(1)*X + COEF(2)
           IF(ABS(X).LT.1.0E-15) THEN
              SINC2=1.0
           ELSE
              SINC2=(SIN(X)/X)**2
           ENDIF
           RNORM = COSTBD/COS(TBMD)*SINC2
C
C compute new grating angle
C
           THETA = (R0-CARPOS)*2*PI/65536.0 - BETA
           CLAST=CARPOS
        ENDIF
C
C Compute some things that don't change from point to point
C
        TB = THETA+BETA
        TBD = TB + DELTA
        TBMD = TB - DELTA
        COSTBD = COS(TBD)
C
C perform echelle ripple removal for each spectra
C
        DO 500 ISPEC=1,NSPEC
           S = SAMPLE(ISPEC)-280.0
           DS = DELTAS(ISPEC)
           DO 300 I=1,NS
C
C calculate ripple function
C
              E = ATAN(S/F)
              E2 = E/2.0
              X = PI*ORDER*COSTBD*SIN(THETA+E2)/SIN(TB+E2)
              X = COEF(1)*X + COEF(2)
              IF(ABS(X).LT.1.0E-15) THEN
                 SINC2=1.0
              ELSE
                 SINC2=(SIN(X)/X)**2
              ENDIF
              R = COSTBD/COS(TBMD+E)*SINC2
              R = R/RNORM
C
              IF(EPS(I,ISPEC).NE.EPSFIL) THEN
                 IF(R.GT.MINRIP)THEN
                    FLUX(I,ISPEC)=FLUX(I,ISPEC)/R
                    ERR(I,ISPEC)=ERR(I,ISPEC)/R
                 ELSE
                    FLUX(I,ISPEC)=0.0
                    ERR(I,ISPEC)=0.0
                 ENDIF
              ENDIF
              S=S+DS
 300       CONTINUE
 500    CONTINUE
 900    ISTAT=0
        GO TO 1000
 999    ISTAT=1
 1000   RETURN
        END


      subroutine vgcap_inv_calc(iflg,ndummy)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 To compute the saturation from capillary pressure and derivatives for the
CD1 van Genuchten model. The inverse of subroutine vg_cap.f .
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2 4-04-07      george Zyvoloski initial implementation
CD2
CD2 $Log:   /pvcs.config/fehm90/src/vgcap_inv.f_a  $
C**********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3 Identifier   Type    Use     Description
CD3
CD3 sl           real*8   I/O    Liquid saturation on input,
CD3                                  normalized liquid saturation on
CD3                                  output
CD3 slr          real*8   I      Residual liquid saturation
CD3 smr          real*8   I      Maximum liquid saturation
CD3 alpha        real*8   I      Van Ganuchten parameter
CD3 beta         real*8   I      Van Ganuchten parameter
CD3 ac1          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 ac2          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 ac3          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 ac4          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 smcut        real*8   I      Lower cutoff saturation below which a
CD3                                  spline fit is used for capillary
CD3                                  pressure versus saturation
CD3 sucut        real*8   I      Upper cutoff saturation above which a
CD3                                  linear fit is used for capillary
CD3                                  pressure versus saturation
CD3 bc3          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 bc4          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 hp           real*8   O      Capillary pressure
CD3 dhp          real*8   O      Derivative of capillary pressure with
CD3                                  respect to saturation
CD3
CD3 Interface Tables
CD3
CD3 None
CD3
CD3 Files
CD3
CD3 NONE
CD3
C**********************************************************************
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 Global Constants
CD4
CD4 NONE
CD4
CD4 Global Types
CD4
CD4 NONE
CD4
CD4 Global Variables
CD4
CD4 NONE
CD4
CD4 Global Subprograms
CD4
CD4 NONE
CD4
C**********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5 NONE
CD5
CD5 Local Types
CD5
CD5 NONE
CD5
CD5 Local variables
CD5
CD5 Identifier   Type        Description
CD5
CD5 alamda       real*8      Exponent in correlation
CD5 ds           real*8      Reciprocal of demoninator in normalized
CD5                              saturation expression
CD5 denom        real*8      Denominator in normalized saturation
CD5                              expression
CD5 star         real*8      Normalized saturation
CD5 alpi         real*8      Exponent in correlation
CD5 hp           real*8      Capillary pressure before unit conversion
CD5 dhp          real*8      Derivative of hp with respect to saturation
CD5 termstar1    real*8      Term used in capillary pressure calculation
CD5 termstar2    real*8      Term used in capillary pressure calculation
CD5 termb1       real*8      Term used in capillary pressure calculation
CD5 termb2       real*8      Term used in capillary pressure calculation
CD5
CD5 Local Subprograms
CD5
CD5 None
CD5
C**********************************************************************
CD6
CD6 ASSUMPTIONS AND LIMITATIONS
CD6
CD6 N/A
CD6
C**********************************************************************
CD7
CD7 SPECIAL COMMENTS
CD7
CD7  Requirements from SDN: 10086-RD-2.20-00
CD7    SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD7    FEHM Application Version 2.20
CD7
C**********************************************************************
CD8
CD8 REQUIREMENTS TRACEABILITY
CD8
CD8 2.4.4 Relative-permeability and capillary-pressure functions
CD8
C**********************************************************************
CDA
CDA REFERENCES
CDA
CDA See GZSOLVE SRS, MMS, and SDD for documentation.
CDA
C**********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN vgcap_inv
CPS
CPS
CPS END vgcap_inv
CPS
C**********************************************************************
      use comhi
      use comfi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
	use comwt
	use comii
      use comki
      implicit none

      real*8 scutm,hmin,darcyf,tol_l,tol_u,su_cut
      parameter(scutm = 1.d-03)
      parameter(hmin = 1.d-18)
      parameter(darcyf = 1.d12)
      parameter(tol_l  = 1.d-5)
      parameter(tol_u  = 1.d-5)
      parameter(su_cut = 0.99d00)

      integer iz,ndummy,i,irlpd,mi,ieosd,it,ir,j,num_models,ireg
	integer iflg,inode, inr, inr_max, iz_temp
      real*8 alpha,beta,alamda,alpi,smcut,slcut,fac,ds,dhp,rl,rv
      real*8 drls,drvs,rp1,rp2,rp3,rp4,denom,star,hp,rl1,rv1
      real*8 drls1,drvs1,akf,akm,porf,permb,sl,sl_init
      real*8 smcutm,smcutf,alpham,alamdam,facf
      real*8 rpa1, rpa2, rpa3, rpa4, rpa5, cp1, cp3
	real*8 dresids,resid,dels,resid_max ,deriv_tol, approx_deriv
	real*8 ac3,ac4,bc3,bc4,hucut
      real*8 sucut,hlcut,pl,dslh
	parameter (inr_max= 30, deriv_tol = 1.d-7)
      logical null1,ex
      resid_max = max(0.0000001d0,rlptol)
      if(iflg.eq.1) then
C calculate the inverse (S) for VG cap models (all nodes)

         do i = 1,n
           mi = i+ndummy
	     iz_temp = izone_free_nodes(mi)
           if(iz_temp.gt.1) then
            pl = phi(mi)
            if (rlp_flag .eq. 0) then
            ieosd = ieos(mi)
               it = 0
            else
               it = irlp(mi)
            end if
            if(it.eq.0) then
               irpd=0
            else
               irpd = irlpt(it)
            endif
            if(irpd.ge.3.and.irpd.le.8) then
               ieosd = 2
            endif
	         if(irpd.eq.1) then
c
c     linear forsyth(1988) model
c     inverse solved explicitly
c
                 if(iz_temp.eq.2) then
                  cp1=cp1f(it)
                  cp3=cp3f(it)
	             pl = pl - crl(4,1)
				 rlxyf(mi) = (pl+cp1*cp3)/cp1 + rlptol
			     drlxyf(mi) = 1.d0/cp1
				 s(mi) = rlxyf(mi) - rlptol
			   else
	            cp1=cp1f(it)
	             rlxyf(mi) = rlptol
				 s(mi) = 0.0
				 drlxyf(mi) = 1.d0/cp1
			   endif
               else if(irpd.eq.3) then
c VG model
c richard's equation only
		      it = irlp(mi)
	          rp1 = rp1f(it)
                rp2 = rp2f(it)
                rp3 = rp3f(it)
                rp4 = rp4f(it)
	          ac3 = rp9f(it)
	          ac4 = rp10f(it)
	          bc3 = cp1f(it)
	          bc4 = cp2f(it)
c linear fit from slcut to sl=0.0
c first calculate star
                smcut=(rp6f(it)-rp1)/(rp2-rp1)
                smcutm = max(smcut,scutm)
c now calculate sl
	          slcut = smcutm*(rp2-rp1) + rp1
	          alpha = rp3
	          beta = rp4
	          alamda = 1.0-1.0/beta
                alpi = 1.0/alamda
                hucut = 1.0/alpha*(1.0/smcutm**alpi-1.0)**(1.0-alamda)
c cutoff for near sucut = 1 region
                sucut = (0.99d0*(rp2-rp1) + rp1)
	          hlcut = -bc3*(1.-sucut)
	          pl = phi(mi)-crl(4,1)
	          hp = pl/h_to_p
	             call vgcap_inv(1, sl, rp1, rp2, rp3, rp4,
     &              slcut,sucut,hlcut, hucut, ac3, ac4, bc3, bc4,
     &              hp, dslh)
                 if(sl.lt.0.0d0) then
	            sl = 0.0d0

	          else if(sl.gt.1.d0) then
	           sl = 1.0d0
	           dslh = 0.0d0
			   endif
	           rlxyf(mi) = sl + rlptol
                 drlxyf(mi) = -dslh/h_to_p
			   s(mi) = sl
			 endif
			 if(iz_temp.eq.3) then
	          rlxyf(mi) =  rlptol
	          s(mi) = 0.0
			 endif
	  	else
	     sl = 1.0
           rlxyf(mi) = sl
           drlxyf(mi) = 0.0d0
		 s(mi) = sl
		endif
        enddo
c end loop on nodes
      else if(iflg.eq.2) then
c
c single node calculation
c

           mi = ndummy
           if(izone_free_nodes(mi).gt.1) then
            pl = phi(mi)
            if (rlp_flag .eq. 0) then
            ieosd = ieos(mi)
               it = 0
            else
               it = irlp(mi)
            end if
            if(it.eq.0) then
               irpd=0
            else
               irpd = irlpt(it)
            endif
            if(irpd.ge.3.and.irpd.le.8) then
               ieosd = 2
            endif
	         if(irpd.eq.1) then
c
c     linear forsyth(1988) model
c     inverse solved explicitly
c
                   cp1=cp1f(it)
                   cp3=cp3f(it)
	             pl = pl - crl(4,1)
				 rlxyf(mi) = (pl+cp1*cp3)/cp1 + rlptol
			     drlxyf(mi) = 1.d0/cp1
				 s(mi) = rlxyf(mi) - rlptol
               else if(irpd.eq.3) then
c VG model
c richard's equation only
		      it = irlp(mi)
	          rp1 = rp1f(it)
                rp2 = rp2f(it)
                rp3 = rp3f(it)
                rp4 = rp4f(it)
	          ac3 = rp9f(it)
	          ac4 = rp10f(it)
	          bc3 = cp1f(it)
	          bc4 = cp2f(it)
c linear fit from slcut to sl=0.0
c first calculate star
                smcut=(rp6f(it)-rp1)/(rp2-rp1)
                smcutm = max(smcut,scutm)
c now calculate sl
	          slcut = smcutm*(rp2-rp1) + rp1
	          alpha = rp3
	          beta = rp4
	          alamda = 1.0-1.0/beta
                alpi = 1.0/alamda
                hucut = 1.0/alpha*(1.0/smcutm**alpi-1.0)**(1.0-alamda)
c cutoff for near sucut = 1 region
                sucut = (0.99d0*(rp2-rp1) + rp1)
	          hlcut = -bc3*(1.-sucut)
	          pl = phi(mi)-crl(4,1)
	          hp = pl/h_to_p
	             call vgcap_inv(1, sl, rp1, rp2, rp3, rp4,
     &              slcut,sucut,hlcut, hucut, ac3, ac4, bc3, bc4,
     &              hp, dslh)
                 if(sl.lt.0.0d0) then
	            sl = 0.0d0
c	            dslh = 0.0d0
	          else if(sl.gt.1.d0) then
	           sl = 1.0d0
	           dslh = 0.0d0
			   endif
	           rlxyf(mi) = sl + rlptol
                 drlxyf(mi) = -dslh/h_to_p
			   s(mi) = sl
			 endif
	  	else
	     sl = 1.0
           rlxyf(mi) = sl
           drlxyf(mi) = 0.0d0
		 s(mi) = sl
		endif

      endif
      return
      end


program mk_array_seq
  implicit none
  real*8, dimension(2,3) :: arr
  real*8 :: et,tt(2), start, dend, dmid
  integer :: i, j
  integer :: m = 100000
  integer :: n = 10000
  real*8, dimension(:),allocatable :: c,d,t
  real*8, dimension(:,:),allocatable :: a,b,e,f,x,u, y,v

  do i = 1, 2
    do j = 1, 3
      arr(i,j) = 3*(i-1) + j
    enddo
  enddo
  print *, arr(:,:)
  !
  do i = 1, 3
    do j = 1, 2
      arr(j,i) = 2*(i-1) + j
    enddo
  enddo
  print *, arr(:,:)

  allocate(c(m)); c(:) = 0.0d0
  allocate(d(m)); d(:) = 0.0d0
  allocate(t(m)); t(:) = 0.0d0

  allocate(a(1:3,1:m)); a(:,:) = 0.0d0
  allocate(b(1:3,1:m)); b(:,:) = 0.0d0

  allocate(x(1:3,1:n)); x(:,:) = 0.0d0
  allocate(u(1:3,1:n)); u(:,:) = 0.0d0

  allocate(e(1:m,1:3)); e(:,:) = 0.0d0
  allocate(f(1:m,1:3)); f(:,:) = 0.0d0
  allocate(y(1:n,1:3)); y(:,:) = 0.0d0
  allocate(v(1:n,1:3)); v(:,:) = 0.0d0

  ! call random_number()

  call cpu_time(start)
  do  i = 1, n
    ! c(1:m) = COS(b(1,1:m) * x(1,i) + b(2,1:m) * x(2,i) + b(3,1:m) * x(3,i) + d(1:m))
    c(1:m) = b(1,1:m) * x(1,i) + b(2,1:m) * x(2,i) + b(3,1:m) * x(3,i) + d(1:m)
    ! d(1:m) = COS(c(1:m))
    ! t(1:m) = SIN(c(1:m))
    CALL vssincos(m,c,d,t)

    do j=1,3
      ! u(j,i) = 2.0d0 * SUM(a(j,1:m) * COS(c(1:m)))
      u(j,i) = 2.0d0 * SUM(a(j,1:m) * d(1:m)+a(j,1:m) * t(1:m))
    enddo
  enddo

  call cpu_time(dmid)
  do i = 1, n
    ! c(1:m) = COS(e(1:m,1) * y(i,1) + e(1:m,2) * y(i,2) + e(1:m,3) * y(i,3) + d(1:m))
    c(1:m) = e(1:m,1) * y(i,1) + e(1:m,2) * y(i,2) + e(1:m,3) * y(i,3) + d(1:m)
    ! d(1:m) = COS(c(1:m))
    ! t(1:m) = SIN(c(1:m))
    CALL vssincos(m,c,d,t)
    do j = 1, 3
      ! v(i,j) = 2.0d0 * SUM(f(1:m,j) * COS(c(1:m)))
      ! v(i,j) = 2.0d0 * SUM(f(1:m,j) * c(1:m))
      v(i,j) = 2.0d0 * SUM(f(1:m,j) * d(1:m)+f(1:m,j) * t(1:m))
    end do
  end do

  call cpu_time(dend)
  call dtime(tt,et)
  print *, start, dmid, dend
  print *, et, tt(1:2)
end program mk_array_seq


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file shsgc.f
c
c     this file contains code and documentation for subroutines
c     shsgc and shsgci
c
c ... files which must be loaded with shsgc.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine shsgc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    +                 wshsgc,lshsgc,work,lwork,ierror)
c
c     subroutine shsgc performs the spherical harmonic synthesis
c     on the arrays a and b and stores the result in the array g.
c     the synthesis is performed on an equally spaced longitude grid
c     and a gaussian colatitude grid.  the associated legendre functions
c     are recomputed rather than stored as they are in subroutine
c     shsgs.  the synthesis is described below at output parameter
c     g.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the synthesis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the synthesis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of syntheses.  in the program that calls shsgc,
c            the arrays g,a and b can be three dimensional in which
c            case multiple synthesis will be performed.  the third
c            index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shsgc. if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg must
c            be at least nlat/2 if nlat is even or at least (nlat+1)/2
c            if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shsgc. jdg must be at least nlon.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shsgc. mdab must be at least
c            min0((nlon+2)/2,nlat) if nlon is even or at least
c            min0((nlon+1)/2,nlat) if nlon is odd
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shsgc. ndab must be at least nlat
c
c     a,b    two or three dimensional arrays (see the input parameter
c            nt) that contain the coefficients in the spherical harmonic
c            expansion of g(i,j) given below at the definition of the
c            output parameter g.  a(m,n) and b(m,n) are defined for
c            indices m=1,...,mmax and n=m,...,nlat where mmax is the
c            maximum (plus one) longitudinal wave number given by
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     wshsgc an array which must be initialized by subroutine shsgci.
c            once initialized, wshsgc can be used repeatedly by shsgc
c            as long as nlat and nlon remain unchanged.  wshsgc must
c            not be altered between calls of shsgc.
c
c     lshsgc the dimension of the array wshsgc as it appears in the
c            program that calls shsgc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgc must be at least
c
c               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shsgc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if isym is zero then lwork must be at least
c
c                      nlat*(nlon*nt+max0(3*l2,nlon))
c
c            if isym is not zero then lwork must be at least
c
c                      l2*(nlon*nt+max0(3*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     g      a two or three dimensional array (see input parameter nt)
c            that contains the discrete function which is synthesized.
c            g(i,j) contains the value of the function at the gaussian
c            colatitude point theta(i) and longitude point
c            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
c            above at the input parameter isym.  for isym=0, g(i,j)
c            is given by the the equations listed below.  symmetric
c            versions are used when isym is greater than zero.
c
c     the normalized associated legendre functions are given by
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta)
c
c
c     define the maximum (plus one) longitudinal wave number
c     as   mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c          mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     then g(i,j) = the sum from n=0 to n=nlat-1 of
c
c                   .5*pbar(0,n,theta(i))*a(1,n+1)
c
c              plus the sum from m=1 to m=mmax-1 of
c
c                   the sum from n=m to n=nlat-1 of
c
c              pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j))
c                                    -b(m+1,n+1)*sin(m*phi(j)))
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lwshig
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c
c     subroutine shsgci(nlat,nlon,wshsgc,lshsgc,dwork,ldwork,ierror)
c
c     subroutine shsgci initializes the array wshsgc which can then
c     be used repeatedly by subroutines shsgc. it precomputes
c     and stores in wshsgc quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshsgc an array which must be initialized by subroutine shsgci.
c            once initialized, wshsgc can be used repeatedly by shsgc
c            as long as nlat and nlon remain unchanged.  wshsgc must
c            not be altered between calls of shsgc.
c
c     lshsgc the dimension of the array wshsgc as it appears in the
c            program that calls shsgc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgc must be at least
c
c                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
C*PL*ERROR* Comment line too long
c     dwork  a double precision work array that does not have to be saved.
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls shsgci. ldwork must be at least
c
c                 nlat*(nlat+4)
c
c     output parameter
c
c     wshsgc an array which must be initialized before calling shsgc.
c            once initialized, wshsgc can be used repeatedly by shsgc
c            as long as nlat and nlon remain unchanged.  wshsgc must not
c            altered between calls of shsgc.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshsgc
c            = 4  error in the specification of ldwork
c            = 5  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
c ****************************************************************
      SUBROUTINE DSHSGC(NLAT,NLON,MODE,NT,G,IDG,JDG,A,B,MDAB,NDAB,
     +                  WSHSGC,LSHSGC,WORK,LWORK,IERROR)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHSGC
      DOUBLE PRECISION WORK
c     subroutine shsgc performs the spherical harmonic synthesis on
c     a gaussian grid using the coefficients in array(s) a,b and returns
c     the results in array(s) g.  the legendre polynomials are computed
c     as needed in this version.
c
      DIMENSION G(IDG,JDG,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),
     +          WSHSGC(LSHSGC),WORK(LWORK)
c     check input parameters
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (MODE.LT.0 .OR. MODE.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.1) RETURN
c     set limit for m iin a(m,n),b(m,n) computation
      L = MIN0((NLON+2)/2,NLAT)
c     set gaussian point nearest equator pointer
      LATE = (NLAT+MOD(NLAT,2))/2
c     set number of grid points for analysis/synthesis
      LAT = NLAT
      IF (MODE.NE.0) LAT = LATE
      IERROR = 5
      IF (IDG.LT.LAT) RETURN
      IERROR = 6
      IF (JDG.LT.NLON) RETURN
      IERROR = 7
      IF (MDAB.LT.L) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      L1 = L
      L2 = LATE
      IERROR = 9
c     check permanent work space length
      IF (LSHSGC.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 10
c     check temporary work space length
      IF (MODE.EQ.0) THEN
          IF (LWORK.LT.NLAT* (NLON*NT+MAX0(3*L2,NLON))) RETURN
      ELSE
c     mode.ne.0
          IF (LWORK.LT.L2* (NLON*NT+MAX0(3*NLAT,NLON))) RETURN
      END IF
      IERROR = 0
c     starting address  fft values
      IFFT = NLAT + 2*NLAT*LATE + 3* (L* (L-1)/2+ (NLAT-L)* (L-1)) + 1
c     set pointers for internal storage of g and legendre polys
      IPMN = LAT*NLON*NT + 1
      CALL DSHSGC1(NLAT,NLON,L,LAT,MODE,G,IDG,JDG,NT,A,B,MDAB,NDAB,
     +             WSHSGC,WSHSGC(IFFT),LATE,WORK(IPMN),WORK)
      RETURN
      END
      SUBROUTINE DSHSGC1(NLAT,NLON,L,LAT,MODE,GS,IDG,JDG,NT,A,B,MDAB,
     +                  NDAB,W,WFFT,LATE,PMN,G)
      DOUBLE PRECISION GS
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION W
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION PMN
      DOUBLE PRECISION G
      DOUBLE PRECISION T1
      DOUBLE PRECISION T3
      DOUBLE PRECISION T2
      DOUBLE PRECISION T4
      DIMENSION GS(IDG,JDG,NT),A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)
      DIMENSION W(1),PMN(NLAT,LATE,3),G(LAT,NLON,NT),WFFT(1)
c     reconstruct fourier coefficients in g on gaussian grid
c     using coefficients in a,b
c     set m+1 limit for b coefficient calculation
      LM1 = L
      IF (NLON.EQ.L+L-2) LM1 = L - 1
c     initialize to zero
      DO 100 K = 1,NT
          DO 100 J = 1,NLON
              DO 100 I = 1,LAT
                  G(I,J,K) = 0.0D0
  100 CONTINUE
      IF (MODE.EQ.0) THEN
c     set first column in g
          M = 0
c     compute pmn for all i and n=m,...,l-1
          CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
          DO 101 K = 1,NT
c     n even
              DO 102 NP1 = 1,NLAT,2
                  DO 102 I = 1,LATE
                      G(I,1,K) = G(I,1,K) + A(1,NP1,K)*PMN(NP1,I,KM)
  102         CONTINUE
c     n odd
              NL2 = NLAT/2
              DO 103 NP1 = 2,NLAT,2
                  DO 103 I = 1,NL2
                      IS = NLAT - I + 1
                      G(IS,1,K) = G(IS,1,K) + A(1,NP1,K)*PMN(NP1,I,KM)
  103         CONTINUE
c     restore m=0 coefficents (reverse implicit even/odd reduction)
              DO 112 I = 1,NL2
                  IS = NLAT - I + 1
                  T1 = G(I,1,K)
                  T3 = G(IS,1,K)
                  G(I,1,K) = T1 + T3
                  G(IS,1,K) = T1 - T3
  112         CONTINUE
  101     CONTINUE
c     sweep  columns of g for which b is available
          DO 104 MP1 = 2,LM1
              M = MP1 - 1
              MP2 = M + 2
c     compute pmn for all i and n=m,...,l-1
              CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
              DO 105 K = 1,NT
c     for n-m even store (g(i,p,k)+g(nlat-i+1,p,k))/2 in g(i,p,k) p=2*m,
c     for i=1,...,late
                  DO 106 NP1 = MP1,NLAT,2
                      DO 107 I = 1,LATE
                          G(I,2*M,K) = G(I,2*M,K) +
     +                                 A(MP1,NP1,K)*PMN(NP1,I,KM)
                          G(I,2*M+1,K) = G(I,2*M+1,K) +
     +                                   B(MP1,NP1,K)*PMN(NP1,I,KM)
  107                 CONTINUE
  106             CONTINUE
c     for n-m odd store g(i,p,k)-g(nlat-i+1,p,k) in g(nlat-i+1,p,k)
c     for i=1,...,nlat/2 (p=2*m,p=2*m+1)
                  DO 108 NP1 = MP2,NLAT,2
                      DO 109 I = 1,NL2
                          IS = NLAT - I + 1
                          G(IS,2*M,K) = G(IS,2*M,K) +
     +                                  A(MP1,NP1,K)*PMN(NP1,I,KM)
                          G(IS,2*M+1,K) = G(IS,2*M+1,K) +
     +                                    B(MP1,NP1,K)*PMN(NP1,I,KM)
  109                 CONTINUE
  108             CONTINUE
c     now set fourier coefficients using even-odd reduction above
                  DO 110 I = 1,NL2
                      IS = NLAT - I + 1
                      T1 = G(I,2*M,K)
                      T2 = G(I,2*M+1,K)
                      T3 = G(IS,2*M,K)
                      T4 = G(IS,2*M+1,K)
                      G(I,2*M,K) = T1 + T3
                      G(I,2*M+1,K) = T2 + T4
                      G(IS,2*M,K) = T1 - T3
                      G(IS,2*M+1,K) = T2 - T4
  110             CONTINUE
  105         CONTINUE
  104     CONTINUE
c     set last column (using a only)
          IF (NLON.EQ.L+L-2) THEN
              M = L - 1
              CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
              DO 111 K = 1,NT
c     n-m even
                  DO 131 NP1 = L,NLAT,2
                      DO 131 I = 1,LATE
                          G(I,NLON,K) = G(I,NLON,K) +
     +                                  2.0D0*A(L,NP1,K)*PMN(NP1,I,KM)
  131             CONTINUE
                  LP1 = L + 1
c     n-m odd
                  DO 132 NP1 = LP1,NLAT,2
                      DO 132 I = 1,NL2
                          IS = NLAT - I + 1
                          G(IS,NLON,K) = G(IS,NLON,K) +
     +                                   2.0D0*A(L,NP1,K)*PMN(NP1,I,KM)
  132             CONTINUE
                  DO 133 I = 1,NL2
                      IS = NLAT - I + 1
                      T1 = G(I,NLON,K)
                      T3 = G(IS,NLON,K)
                      G(I,NLON,K) = T1 + T3
                      G(IS,NLON,K) = T1 - T3
  133             CONTINUE
  111         CONTINUE
          END IF
      ELSE
c     half sphere (mode.ne.0)
c     set first column in g
          M = 0
          MEO = 1
          IF (MODE.EQ.1) MEO = 2
          MS = M + MEO
c     compute pmn for all i and n=m,...,l-1
          CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
          DO 113 K = 1,NT
              DO 113 NP1 = MS,NLAT,2
                  DO 113 I = 1,LATE
                      G(I,1,K) = G(I,1,K) + A(1,NP1,K)*PMN(NP1,I,KM)
  113     CONTINUE
c     sweep interior columns of g
          DO 114 MP1 = 2,LM1
              M = MP1 - 1
              MS = M + MEO
c     compute pmn for all i and n=m,...,l-1
              CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
              DO 115 K = 1,NT
                  DO 115 NP1 = MS,NLAT,2
                      DO 115 I = 1,LATE
                          G(I,2*M,K) = G(I,2*M,K) +
     +                                 A(MP1,NP1,K)*PMN(NP1,I,KM)
                          G(I,2*M+1,K) = G(I,2*M+1,K) +
     +                                   B(MP1,NP1,K)*PMN(NP1,I,KM)
  115         CONTINUE
  114     CONTINUE
          IF (NLON.EQ.L+L-2) THEN
c     set last column
              M = L - 1
              CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
              NS = L
              IF (MODE.EQ.1) NS = L + 1
              DO 116 K = 1,NT
                  DO 116 I = 1,LATE
                      DO 116 NP1 = NS,NLAT,2
                          G(I,NLON,K) = G(I,NLON,K) +
     +                                  2.0D0*A(L,NP1,K)*PMN(NP1,I,KM)
  116         CONTINUE
          END IF
      END IF
c     do inverse fourier transform
      DO 120 K = 1,NT
          CALL DHRFFTB(LAT,NLON,G(1,1,K),LAT,WFFT,PMN)
  120 CONTINUE
c     scale output in gs
      DO 122 K = 1,NT
          DO 122 J = 1,NLON
              DO 122 I = 1,LAT
                  GS(I,J,K) = 0.5D0*G(I,J,K)
  122 CONTINUE
      RETURN
      END
      SUBROUTINE DSHSGCI(NLAT,NLON,WSHSGC,LSHSGC,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHSGC
c     this subroutine must be called before calling shsgc with
c     fixed nlat,nlon. it precomputes quantites such as the gaussian
c     points and weights, m=0,m=1 legendre polynomials, recursion
c     recursion coefficients.
      DIMENSION WSHSGC(LSHSGC)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+MOD(NLAT,2))/2
      L1 = L
      L2 = LATE
      IERROR = 3
c     check permanent work space length
      IF (LSHSGC.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 4
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
c     set pointers
      I1 = 1
      I2 = I1 + NLAT
      I3 = I2 + NLAT*LATE
      I4 = I3 + NLAT*LATE
      I5 = I4 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I6 = I5 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I7 = I6 + L* (L-1)/2 + (NLAT-L)* (L-1)
c     set indices in temp work for double precision gaussian wts and pts
      IDTH = 1
      IDWTS = IDTH + NLAT
      IW = IDWTS + NLAT
      CALL DSHSGCI1(NLAT,NLON,L,LATE,WSHSGC(I1),WSHSGC(I2),WSHSGC(I3),
     +              WSHSGC(I4),WSHSGC(I5),WSHSGC(I6),WSHSGC(I7),
     +              DWORK(IDTH),DWORK(IDWTS),DWORK(IW),IERROR)
      IF (IERROR.NE.0) IERROR = 5
      RETURN
      END
      SUBROUTINE DSHSGCI1(NLAT,NLON,L,LATE,WTS,P0N,P1N,ABEL,BBEL,CBEL,
     +                    WFFT,DTHETA,DWTS,WORK,IER)
      DOUBLE PRECISION WTS
      DOUBLE PRECISION P0N
      DOUBLE PRECISION P1N
      DOUBLE PRECISION ABEL
      DOUBLE PRECISION BBEL
      DOUBLE PRECISION CBEL
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION FN
      DOUBLE PRECISION FM
      DIMENSION WTS(NLAT),P0N(NLAT,LATE),P1N(NLAT,LATE),ABEL(1),BBEL(1),
     +          CBEL(1),WFFT(1),DTHETA(NLAT),DWTS(NLAT)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION PB,DTHETA,DWTS,WORK(*)
c     compute the nlat  gaussian points and weights, the
c     m=0,1 legendre polys for gaussian points and all n,
c     and the legendre recursion coefficients
c     define index function used in storing
c     arrays for recursion coefficients (functions of (m,n))
c     the index function indx(m,n) is defined so that
c     the pairs (m,n) map to [1,2,...,indx(l-1,l-1)] with no
c     "holes" as m varies from 2 to n and n varies from 2 to l-1.
c     (m=0,1 are set from p0n,p1n for all n)
c     define for 2.le.n.le.l-1
      INDX(M,N) = (N-1)* (N-2)/2 + M - 1
c     define index function for l.le.n.le.nlat
      IMNDX(M,N) = L* (L-1)/2 + (N-L-1)* (L-1) + M - 1
c     preset quantites for fourier transform
      CALL DHRFFTI(NLON,WFFT)
c     compute double precision gaussian points and weights
c     lw = 4*nlat*(nlat+1)+2
      LW = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHETA,DWTS,WORK,LW,IER)
      IF (IER.NE.0) RETURN
c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      DO 100 I = 1,NLAT
          WTS(I) = DWTS(I)
  100 CONTINUE
c     initialize p0n,p1n using double precision dnlfk,dnlft
      DO 101 NP1 = 1,NLAT
          DO 101 I = 1,LATE
              P0N(NP1,I) = 0.0D0
              P1N(NP1,I) = 0.0D0
  101 CONTINUE
c     compute m=n=0 legendre polynomials for all theta(i)
      NP1 = 1
      N = 0
      M = 0
      CALL DDNLFK(M,N,WORK)
      DO 103 I = 1,LATE
          CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
          P0N(1,I) = PB
  103 CONTINUE
c     compute p0n,p1n for all theta(i) when n.gt.0
      DO 104 NP1 = 2,NLAT
          N = NP1 - 1
          M = 0
          CALL DDNLFK(M,N,WORK)
          DO 105 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P0N(NP1,I) = PB
  105     CONTINUE
c     compute m=1 legendre polynomials for all n and theta(i)
          M = 1
          CALL DDNLFK(M,N,WORK)
          DO 106 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P1N(NP1,I) = PB
  106     CONTINUE
  104 CONTINUE
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      DO 107 N = 2,NLAT
          FN = DBLE(N)
          MLIM = MIN0(N,L)
          DO 107 M = 2,MLIM
              FM = DBLE(M)
              IMN = INDX(M,N)
              IF (N.GE.L) IMN = IMNDX(M,N)
              ABEL(IMN) = SQRT(((2*FN+1)* (FM+FN-2)* (FM+FN-3))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              BBEL(IMN) = SQRT(((2*FN+1)* (FN-FM-1)* (FN-FM))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              CBEL(IMN) = SQRT(((FN-FM+1)* (FN-FM+2))/
     +                    (((FN+FM-1)* (FN+FM))))
  107 CONTINUE
      RETURN
      END


     SUBROUTINE DCTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
     IMPLICIT NONE
!      THIS VERSION RUNS IN REVERSE
!      PURPOSE solves the cyclic/periodic tridiagonal system, see LAPACK routine DGTSV for comparison
!      Copyright (c) 2021   Anthony M de Beus
       INTEGER, PARAMETER :: wp = KIND(0.0D0) ! working precision
!      Arguments copied/modified from dgtsv.f *  -- LAPACK routine (version 3.1) --
!      Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
!      November 2006
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 4.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  DL      (input) working precision array, dimension (N)
!          On entry, DL must contain the sub-diagonal elements of A. The first term
!          wraps around to the last column first row
!
!  D       (input) working precision array, dimension (N)
!          On entry, D must contain the diagonal elements of A.
!
!  DU      (input) working precision array, dimension (N)
!          On entry, DU must contain the super-diagonal elements
!          of A. The last term wraps around to the first column last row
!
!  B       (input/output) working precision array, dimension (LDB,NRHS)
!          On entry, the N by NRHS matrix of right hand side matrix B.
!          On exit, if INFO = 0, the N by NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, a determinant is exactly zero, and the solution
!               has not been computed.
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  N = 9
!              D1  DU1 0   0   0   0   0   0   DL1
!              DL2 D2  DU2 0   0   0   0   0   0
!              0   DL3 D3  DU3 0   0   0   0   0
!              0   0   DL4 D4  DU4 0   0   0   0
!              0   0   0   DL5 D5  DU5 0   0   0
!              0   0   0   0   DL6 D6  DU6 0   0
!              0   0   0   0   0   DL7 D7  DU7 0
!              0   0   0   0   0   0   DL8 D8  DU8
!              DU9 0   0   0   0   0   0   DL9 D9
!
!      .. Scalar Arguments ..
       INTEGER, INTENT(IN) :: LDB, N, NRHS
       INTEGER, INTENT(OUT) :: INFO
!      ..
!      .. Array Arguments ..
       REAL(wp), INTENT(IN) :: D( * ), DL( * ), DU( * )  ! no output no LU factors
       REAL(wp), INTENT(INOUT) :: B( LDB, * ) ! on entry RHS, on exit, solution
!      ..
       REAL(wp) :: ud(2,2,0:N/2+1),ue(2,0:N/2+1,NRHS),DET  !  ud is my set of matrices Aj ue is my vectors vj
       INTEGER :: i,j,k,p

!      needed for f90+ calling of f77 routines
       INTERFACE
          SUBROUTINE XERBLA( SRNAME, INFO )
!         .. Scalar Arguments ..
          CHARACTER*6        SRNAME          !CHARACTER(6)
          INTEGER            INFO
          END SUBROUTINE XERBLA
       END INTERFACE

!      INFO handling copied/modified from dgtsv.f *  -- LAPACK routine (version 3.1) --
!      Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
!      November 2006
       INFO = 0
       IF( N.LT.4 ) THEN
         INFO = -1
       ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
       END IF
       IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DCTSV ', -INFO )
         RETURN
       END IF
       IF( N.EQ.0 ) RETURN
!      End INFO handling
       p=mod(N,2)

!      FIRST EQUATION
!       ud(N/2+1)=((0,1),(1,0) & ue(N/2+1) = (0,0) when p==0
       if (p == 0) then
        ud(:,:,N/2+1)=0
        ud(1,2,N/2+1)=1
        ud(2,1,N/2+1)=1
        ue(:,N/2+1,:)=0
       else
        if ( D((N+1)/2) /= 0) then
        ud(1,1,(N+1)/2)=-DL((N+1)/2)/D((N+1)/2)
        ud(1,2,(N+1)/2)=-DU((N+1)/2)/D((N+1)/2)
        ud(2,1,(N+1)/2)=-DL((N+1)/2)/D((N+1)/2)
        ud(2,2,(N+1)/2)=-DU((N+1)/2)/D((N+1)/2)
        ue(1,(N+1)/2,1:NRHS)=B((N+1)/2,1:NRHS)/D((N+1)/2)
        ue(2,(N+1)/2,1:NRHS)=B((N+1)/2,1:NRHS)/D((N+1)/2)
        else
         INFO=(N+1)/2
         CALL XERBLA( 'DCTSV ', -INFO )
         RETURN
        endif
       endif

!      ALL BUT THE LAST EQUATION
       do j=(N-p)/2,2,-1
        DET=D(j)*D(1-j+N)+DU(j)*D(1-j+N)*ud(1,1,1+j)-&
            DU(j)*DL(1-j+N)*ud(1,2,1+j)*ud(2,1,1+j)+&
            D(j)*DL(1-j+N)*ud(2,2,1+j)+&
            DU(j)*DL(1-j+N)*ud(1,1,1+j)*ud(2,2,1+j)

        IF (DET /= 0) THEN
         ud(1,1,j)=-((DL(j)*(D(1-j+N)+DL(1-j+N)*ud(2,2,1+j)))/DET)
         ud(1,2,j)=(DU(j)*DU(1-j+N)*ud(1,2,1+j))/DET
         ud(2,1,j)=(DL(j)*DL(1-j+N)*ud(2,1,1+j))/DET
         ud(2,2,j)=-((DU(1-j+N)*(D(j)+DU(j)*ud(1,1,1+j)))/DET)
         ue(1,j,1:NRHS)=(-DU(j)*(B(1-j+N,1:NRHS)-DL(1-j+N)*ue(2,1+j,1:NRHS))*ud(1,2,1+j)+&
                (B(j,1:NRHS)-DU(j)*ue(1,1+j,1:NRHS))*(D(1-j+N)+DL(1-j+N)*ud(2,2,1+j)))/DET
         ue(2,j,1:NRHS)=((B(1-j+N,1:NRHS)-DL(1-j+N)*ue(2,1+j,1:NRHS))*(D(j)+DU(j)*ud(1,1,1+j))-&
                DL(1-j+N)*(B(j,1:NRHS)-DU(j)*ue(1,1+j,1:NRHS))*ud(2,1,1+j))/DET

        ELSE
         INFO=j
         CALL XERBLA( 'DCTSV ', -INFO )
         RETURN
        ENDIF
       end do

!      LAST EQUATION
!      NO ud(,,j); ue(,1) iS THE SOLUTION AT 1,N
        DET=D(1)*D(N)-DU(N)*DL(1)+DU(1)*D(N)*ud(1,1,2)-&
            DU(1)*DU(N)*ud(1,2,2)-DL(1)*DL(N)*ud(2,1,2)-&
            DU(1)*DL(N)*ud(1,2,2)*ud(2,1,2)+D(1)*DL(N)*ud(2,2,2)+&
            DU(1)*DL(N)*ud(1,1,2)*ud(2,2,2)

        IF (DET /= 0) THEN
         ue(1,1,1:NRHS)=((B(N,1:NRHS)-DL(N)*ue(2,2,1:NRHS))*(-DL(1)-DU(1)*ud(1,2,2))+&
           (B(1,1:NRHS)-DU(1)*ue(1,2,1:NRHS))*(D(N)+DL(N)*ud(2,2,2)))/DET
         ue(2,1,1:NRHS)=((B(N,1:NRHS)-DL(N)*ue(2,2,1:NRHS))*(D(1)+DU(1)*ud(1,1,2))+&
           (B(1,1:NRHS)-DU(1)*ue(1,2,1:NRHS))*(-DU(N)-DL(N)*ud(2,1,2)))/DET

         B(1,1:NRHS)=ue(1,1,1:NRHS)
         B(N,1:NRHS)=ue(2,1,1:NRHS)
        ELSE
         INFO=j
         CALL XERBLA( 'DCTSV ', -INFO )
         RETURN
        ENDIF

!      BACKSUBSTITUTION B(j+1)=UE(j+1)+UD(:,:,j+1)*B(j)
       do i=1,(N-p)/2-1
        B(i+1,1:NRHS)=ue(1,i+1,1:NRHS)+ud(1,1,i+1)*B(i,1:NRHS)+ud(1,2,i+1)*B(N-i+1,1:NRHS)
        B(N-i,1:NRHS)=ue(2,i+1,1:NRHS)+ud(2,1,i+1)*B(i,1:NRHS)+ud(2,2,i+1)*B(N-i+1,1:NRHS)
       end do
       if (p /=0) then  ! take the average for the middle value
        i=(N-p)/2
        B(i+1,1:NRHS)=(ue(1,i+1,1:NRHS)+ud(1,1,i+1)*B(i,1:NRHS)+ud(1,2,i+1)*B(N-i+1,1:NRHS)+&
                       ue(2,i+1,1:NRHS)+ud(2,1,i+1)*B(i,1:NRHS)+ud(2,2,i+1)*B(N-i+1,1:NRHS))/2
       endif

     end subroutine DCTSV


! Author: Vladimir Fuka
! Solution of Euler equations for compressible fluid
! in 1D - Riemann problem
! added subroutine by Donato Cecere :FLUXESCULD, and a subroutine for not uniform grid.

program Euler1D
    use CUeuler
    implicit none

    real(KND),allocatable,dimension(:):: rho,rhou,e,x
    integer i,fnum,frames
    real(KND) timefram1,timefram2

 !Not uniform grid
    real(KND) yp(3), r(3)
    real(KND) xp(3)
    yp(1) = -1.0
    yp(2) =  0.6
    yp(3) =  1.0
    r(1)  =  0.5
    r(2)  =  0.3
    r(3)  =  1.0
!Not uniform grid

    open(11,file="euler.conf")

    read (11,FMT='(/)')
    read (11,*) FLUXtype
    write(*,*) 'Flux type:',FLUXtype
    if ((FLUXtype<1).or.(FLUXtype>5)) then
     write (*,*) "Wrong flux type, set to 5...MUSTA"
     FLUXtype=5
    endif

    read (11,FMT='(/)')
    read (11,*) MUSTAstages
    write (*,*) 'Number of MUSTA stages:',MUSTAstages
    if (MUSTAstages<1) then
     write (*,*) "Number of MUSTA stages must be positive, set to 4."
     MUSTAstages=4
    endif

    read (11,FMT='(/)')
    read (11,*) RECtype
    write (*,*) 'Reconstruction type:',RECtype
    if ((RECtype<1).or.(RECtype>2)) then
     write (*,*) "Wrong reconstruction type, set to 2...p. linear."
     FLUXtype=5
    endif

    read (11,FMT='(/)')
    read (11,*) limitertype
    write (*,*) 'Limiter type:',limitertype
    if ((limitertype<1).or.(limitertype>3)) then
     write (*,*) "Wrong limiter type, set to 1...minmod."
     FLUXtype=1
    endif

    read (11,FMT='(/)')
    read (11,*) limparam
    read (11,FMT='(/)')
    read (11,*) RKtype
    write (*,*) 'Runge-Kutta method:',RKtype
    if ((RKtype<1).or.(RKtype>4)) then
     write(*,*) "Wrong Runge-Kutta method type, set to 2...2. order."
     RKtype=2
    elseif ((RKtype==4).and.((FLUXtype<3).or.(FLUXtype>4))) then
     write(*,*) "Full discrete scheme can be only Lax-Friedrichs or Lax-Wendroff. Runge-Kutta type set to 2...2. order."
     RKtype=2
    endif

    read (11,FMT='(/)')
    read (11,*) nt
    if (nt<1) then
     write (*,*) "Number of timesteps must be positive, set to 1000."
     nt=1000
    endif

    read (11,FMT='(/)')
    read (11,*) tend
    write (*,*) 'End time:',tend
    if (tend<=0) then
     write (*,*) "End time must be positive, set to 0.1"
     tend=0.1
    endif

    read (11,FMT='(/)')
    read (11,*) xl
    read (11,FMT='(/)')
    read (11,*) xr
    if (xl>=xr) then
     write (*,*) "Right margin must be greater then the left one, set to xl+2."
     xr=xl+2
    endif

    read (11,FMT='(/)')
    read (11,*) nx
    if (nt<1) then
     write (*,*) "Number of cells must be positive, set to 100."
     nx=100
    endif

    read (11,FMT='(/)')
    read (11,*) CFL
    if (CFL<=0) then
     write (*,*) "CFL must be positive, set to 0.5."
     CFL=0.5
    endif

    read (11,FMT='(/)')
    read (11,*) extype
    write (*,*) 'Problem type: ',extype
    if ((extype<1).or.(extype>2)) then
     write (*,*) "Wrong type of problem to solution, sett to 1...Riemann problem."
     extype=1
    endif

    read (11,FMT='(/)')
    read (11,*) rhoLEFT
    if (rhoLEFT<=0) then
     write (*,*) "Left state density must be positive, set to 0.1."
     rhoLEFT=0.1
    endif

    read (11,FMT='(/)')
    read (11,*) rhouLEFT

    read (11,FMT='(/)')
    read (11,*) eLEFT
    if (eLEFT<=0) then
     write (*,*) "Left state energy must be positive, set to 0.5."
     eLEFT=0.5
    endif

    read (11,FMT='(/)')
    read (11,*) rhoRIGHT
    if (rhoRIGHT<=0) then
     write (*,*) "RIGHT state density must be positive, set to 0.1."
     rhoRIGHT=0.1
    endif

    read (11,FMT='(/)')
    read (11,*) rhouRIGHT

    read (11,FMT='(/)')
    read (11,*) eRIGHT
    if (eRIGHT<=0) then
     write (*,*) "Right state energy must be positive, set to 0.5."
     eRIGHT=0.5
    endif

    read (11,FMT='(/)')
    read (11,*) frames
    read (11,FMT='(/)')
    read (11,*) timefram1
    if ((frames>0).and.(timefram1<0)) then
     write (*,*) "Time of first frame must be nonnegative, set to 0.001."
     timefram1=0.001
    endif

    read (11,FMT='(/)')
    read (11,*) timefram2
    if ((frames>0).and.(timefram2<timefram1)) then
     write (*,*) "Time of last frame must be nonnegative, set to tend-0.001."
     timefram2=tend-0.001
    elseif ((frames>0).and.(timefram2>tend)) then
     write (*,*) "Time of last frame can't be greater then tend, set to tend-0.001.",frames,timefram2,tend
     timefram2=tend-0.001
    endif

    read (11,FMT='(/)')
    read (11,*) outputtype
    if ((frames>0).and.(outputtype==1)) then
     write (*,*) "Frames for animation will be stored as muliple *.dat files."
    elseif ((frames>0).and.(outputtype==2)) then
    elseif ((frames>0).and.((outputtype<1).or.(outputtype>2))) then
     write (*,*) "Warning! No filetype set for animation frames, defaulting to text files."
     outputtype=1
    endif
    close(11)

    dx=(xr-xl)/nx

    allocate(x(-2:nx+3))

!   UNIFORM GRID
    forall(i=-2:nx+3)
     x(i)=xl+dx*(i-1._KND/2._KND)
    endforall

!   NOT UNIFORM GRID
!    call linearMesh(yp, r, 3, x(1:nx), nx)
!	 dx = x(nx)-x(nx-1)
!	do i=1,3
!     x(nx+i) = x(nx+i-1) + dx
!	enddo
!     dx = x(2)-x(1)
!	do i=0,-2,-1
!     x(i) = x(i+1) - dx
!	enddo

    allocate(rho(-2:nx+3))
    allocate(rhou(-2:nx+3))
    allocate(e(-2:nx+3))

    if (extype==1) then
     forall(i=-2:nx+3,x(i)<xl+(xr-xl)/2._KND) !forall(i=-1:nx+2,x(i)<xl+(xr-xl)/2._KND)
      rho(i)=rhoLEFT
      rhou(i)=rhouLEFT
      e(i)=eLEFT
     endforall
     forall(i=-2:nx+3,x(i)>=xl+(xr-xl)/2._KND) !forall(i=-1:nx+2,x(i)>=xl+(xr-xl)/2._KND)
      rho(i)=rhoRIGHT
      rhou(i)=rhouRIGHT
      e(i)=eRIGHT
     endforall
    elseif (extype==2) then
     forall(i=1:nx)
      rho(i)=2 - (cos(pi*x(i)+dx*2._KND)-cos(pi*x(i)-dx*2._KND))/(dx*pi)
      rhou(i)=rho(i)
      e(i)=rho(i)
     endforall
    endif

   if (outputtype==2)    call open_time_evol !Create the history file

    time=0
    do i=1,nt
     write(*,*) "i=",i
     write(*,*) "time=",time
     dt=DTIME(rho,rhou,e)

     if (dt>(tend-time)) dt=(tend-time)
     write (*,*) 'Initial dt ', dt
     call TMARCH(rho,rhou,e,x)
     time=time+dt
     if (frames>0)then
       if ((time>=timefram1).and.(time<=timefram2+(timefram2-timefram1)/(frames-1))&
       .and.(time>=timefram1+fnum*(timefram2-timefram1)/(frames-1))) then
        fnum=fnum+1
       if (outputtype==1) then
        call FRAME(x,rho,rhou,e,fnum)
       elseif (outputtype==2) then
        call time_evol(x,rho,rhou,e,fnum)
       endif
   endif
     endif
     if (time>=tend) EXIT
    enddo
    write(*,*) "endtime=",time

    call OUTPUT(x,rho,rhou,e)
    if (outputtype==1) call close_time_evol
    deallocate(x,rho,rhou,e)

 contains

  real(KND) function DTIME(rho,rhou,e)
  real(KND),dimension(-2:):: rho,rhou,e
  real(KND) p,c,S,pom
  integer i

     S=0
     do i=1,nx
         p=(gamma-1._KND)*(e(i)-(1._KND/2._KND)*(rhou(i)*rhou(i))/rho(i))
	 if (p<0) then
	           write (*,*) "p<0!!!",e(i),rho(i),rhou(i)/rho(i)
                   p=0
         endif
         c=SQRT(gamma*p/rho(i))
         pom=MAX(ABS(rhou(i)/rho(i)-c),ABS(rhou(i)/rho(i)+c))
         if (S<p) S=pom
     enddo
    DTIME=CFL*dx/S
  endfunction DTIME

  subroutine OUTPUT(x,rho,rhou,e)
  real(KND),dimension(-2:):: x,rho,rhou,e
  integer i
    write (*,"(a)",advance="no") "Saving....."
    open(11,file="rho.txt")
    do i=1,nx
        write(11,*) x(i),rho(i)
    enddo
    close(11)
    open(11,file="u.txt")
    do i=1,nx
        write(11,*) x(i),rhou(i)/rho(i)
    enddo
    close(11)
    open(11,file="rhou.txt")
    do i=1,nx
        write(11,*) x(i),rhou(i)
    enddo
    close(11)
    open(11,file="e.txt")
    do i=1,nx
        write(11,*) x(i),e(i)
    enddo
    close(11)
    open(11,file="p.txt")
    do i=1,nx
        write(11,*) x(i),(gamma-1._KND)*(e(i)-(1._KND/2._KND)*(rhou(i))*(rhou(i))/rho(i))
    enddo
    close(11)
    open(11,file="m.txt")
    do i=1,nx
        write(11,*) x(i),rhou(i)/(rho(i)*SQRT(ABS(gamma*(gamma-1._KND)&
                          *(e(i)-(1._KND/2._KND)*(rhou(i))*(rhou(i))/rho(i))/rho(i))))
    enddo
    close(11)
    write(*,"(a)") "saved"
  endsubroutine OUTPUT

  subroutine FRAME(x,rho,rhou,e,n)
  real(KND),dimension(-2:):: x,rho,rhou,e
  integer i,n
  character fname*10,str*70

   write(fname(1:3),"(I3.3)") n
   fname(4:7)=".dat"
   write(*,*) "Saving frame:",fname(1:3),"   time:",time

   open(11,file=fname(1:7))

   do i=1,nx
       write(11,*) x(i),rho(i),rhou(i)/rho(i), &
	   (gamma-1._KND)*(e(i)-(1._KND/2._KND)*(rhou(i))*(rhou(i))/rho(i))
   enddo
   close(11)

   write (*,*) "Saved frame",n
  endsubroutine FRAME

     SUBROUTINE open_time_evol

      INTEGER s

      CHARACTER VAR_FLUID*298, VAR_Yi*298, VAR_CK*298, VAR_PROP*298, Tec_string*500

      VAR_FLUID = "variables = ""z [m]"", ""rho [kg/m^3]"", ""Uz [m/s]"", ""P [Pa]"""

      Tec_string = VAR_FLUID

      open (30,file='HISTORY.plt', POSITION='APPEND', STATUS='UNKNOWN', ACTION='WRITE')
        write(30,'(500(x,a))') Tec_string

      END subroutine open_time_evol

      SUBROUTINE time_evol(x,rho,rhou,e,n)
      real(KND),dimension(-2:):: x,rho,rhou,e
      integer i, n, s

      CHARACTER*15 FORCHR,nvar
      write(Nvar,45) 4
   45 format(I1)
   !43 format('(F20.12,1X,F20.12,1X,F20.12,1X,F20.12,1X)')

      write(30,*) 'ZONE T="time=',time,'"'
      do i= 1,nx
        write(30,*) x(i),rho(i),rhou(i)/rho(i), &
	   (gamma-1.D0)*(e(i)-(1.D0/2.D0)*(rhou(i))*(rhou(i))/rho(i))
      enddo

      END subroutine time_evol

      SUBROUTINE close_time_evol

      close(30)
      END subroutine close_time_evol

end


**********************************************************************
* This file contains routines for searching points in the grid.
* All the routines here are trimmed for quadrilateral elements.
*
* There are also some general auxiliary routines to be found here
* which are valid for more general purposes.
**********************************************************************

**********************************************************************
* Purpose: returns the element containing the point (x0,y0) by a
* raytracing method
* Constructs a ray from the old node position (whose element number
* is known) and traces it to the actual position
*
* In:
*  X0,
*  Y0     - Coordinates of the (moved) point to determine the element
*           number where this point resides in
*  IVT0   - Number of the vertex with coordinates (X0,Y0);
*           Only for output purposes in case of an error; can be
*           ignored if necessary!
*  IELOLD - Element in which the not-moved point (XALT,YALT)
*           resides in
*
* Out:
*  IEL    - Number of the element where (X0,Y0) stays in
*  XALT,
*  YALT   - Coordinates of the last found point of the ray inside
*           of the domain,
*           a) before the point (X0,Y0), if (X0,Y0) is inside of
*              the domain
*           b) before leaving the domain in direction of (X0,Y0)
*              in case of an error (domain left)
**********************************************************************

      SUBROUTINE PSRCH1(X0,Y0,XALT,YALT,IVT0,DCORVG,KVERT,KADJ,IELOLD,
     *                  IEL)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'

      INTEGER MAXIT
      PARAMETER (MAXIT=100)

C parameters

      DOUBLE PRECISION X0,Y0,XALT,YALT
      DOUBLE PRECISION DCORVG(2,*)
      INTEGER IVT0,KVERT,KADJ
      INTEGER IELOLD,IEL

      DIMENSION KVERT(NNVE,*),KADJ(NNVE,*)

C local variables

      DOUBLE PRECISION X1EDGE,Y1EDGE,X2EDGE,Y2EDGE
      INTEGER IVE,IDX,NVE
      LOGICAL BAUX,ISINE2,BINTSE

      NVE=4
      IEL=IELOLD

C We restrict our raytracing search to 100 neighbour cells;
C let's hope a point is not moved more than 100 elements in one step...

      DO IDX=1,MAXIT

C *** finished - our node is in element iel
C In that case, jump out of this subroutine.

        IF (ISINE2(X0,Y0,IEL,DCORVG,KVERT)) GOTO 110

C *** calculate point of intersection with one of the four surrounding edges
C *** take the center of the starting element as starting point of the ray

        XALT=0.5D0*(DCORVG(1,KVERT(1,IEL))+DCORVG(1,KVERT(3,IEL)))
        YALT=0.5D0*(DCORVG(2,KVERT(1,IEL))+DCORVG(2,KVERT(3,IEL)))

        DO IVE=1,NVE
C *** don't jump back to the old element
          IF (KADJ(IVE,IEL).NE.IELOLD) THEN
            X1EDGE=DCORVG(1,KVERT(IVE,IEL))
            Y1EDGE=DCORVG(2,KVERT(IVE,IEL))
            X2EDGE=DCORVG(1,KVERT(MOD(IVE,NVE)+1,IEL))
            Y2EDGE=DCORVG(2,KVERT(MOD(IVE,NVE)+1,IEL))
            BAUX=BINTSE(XALT,YALT,X0,Y0,X1EDGE,Y1EDGE,X2EDGE,Y2EDGE)

C *** found a point of intersection

            IF (BAUX) THEN
C go on searching in the neighbour element
              IELOLD=IEL
C Stop here if we leave our domain. To test that use the fact that
C KADJ()=0 if there is no neighbour element!
              IF (KADJ(IVE,IELOLD).EQ.0) GOTO 310
              IEL=KADJ(IVE,IELOLD)
              GOTO 210
            END IF
          END IF
        END DO

210   END DO

C If the search is successful, we cancel the DO-loop and jump out
C of this routine; otherwise we halt the program because we have not
C been able to find the element where the point resides in...

310   WRITE (*,FMT='(A,I7)')
     *        'Found no Element containing the node ',IVT0
      WRITE (*,FMT='(A,2F12.7)') 'Position (x/y)=',X0,Y0
      STOP

110   END

**********************************************************************
* This subroutine tests, if the two line segments between (1,2)
* and (3,4) truely intersect.
*
* To achive this, we test the position of point 1 with respect to
* line (3,4) and do same for point 2. We repeat this with the points
* 3 and 4 with respect to line (1,2). If point 1 is "under" the line
* (3,4) and point 2 is "over" line 3,4 (or vice versa) and
* if point 3 is "left" from line (1,2) and point 4 is "right" from
* line (1,2) (or vice versa), then the two lines intersect.
*
* To determine the position e.g. of point 1 with respect to line
* 3,4, we consider the orientation of the triangle (3,4,1) by
* computing the oriented area of the triangle.
* If the oriented area of triangle (3,4,1) has a different sign
* that triangle (3,4,2), line (1,2) intersects line (3,4)!
*
* In:
*  DX1,DY1,
*  DX2,DY2  - The start- and endpoint of the first line segment
*  DX3,DY3,
*  DX4,DY4  - The start- and endpoint of the 2nd line segment
*
* Result:
*  =true,  if the two line segments intersecvt
*  =false, otherwise
**********************************************************************

      LOGICAL FUNCTION BINTSE(dx1,dy1,dx2, dy2, dx3, dy3, dx4, dy4)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'

C Parameters: coordinates of the for points defining the two lines
      DOUBLE PRECISION dx1, dy1, dx2, dy2, dx3, dy3, dx4, dy4

C local variables: aux parameters
      DOUBLE PRECISION daux1, daux2, daux3, daux4

C position of point 3 with respect to line between 1 and 2

      DAUX3 = (DX2-DX1)*(DY3-DY1) - (DY2-DY1)*(DX3-DX1)

C position of point 4 with respect to line between 1 and 2

      DAUX4 = (DX2-DX1)*(DY4-DY1) - (DY2-DY1)*(DX4-DX1)

C position of point 1 with respect to line between 3 and 4

      DAUX1 = (DX4-DX3)*(DY1-DY3) - (DY4-DY3)*(DX1-DX3)

C position of point 2 with respect to line between 3 and 4

      DAUX2 = (DX4-DX3)*(DY2-DY3) - (DY4-DY3)*(DX2-DX3)

C Determine if the lines truely intersect by checking the sign

      BINTSE = ((DAUX3*DAUX4.LE.0D0).AND.(DAUX1*DAUX2.LE.0D0))

C      if ((daux3*daux4.le.-1.0D-28).and.(daux1*daux2.le.-1.0D-28)) then

      END

**********************************************************************
* Test if a point is inside of an element.
*
* Returns .true. if the position (x0,y0) is in the element IEL.
*
* In:
*   X0,Y0  - Position of an arbitrary point
*   DCORVG - coordinates of all points
*   KVERT  - Vertex numbers on all elements
*   IEL    - Element number
*
* Result:
*   =true,  if (X0,Y0) is in element IEL
*   =false, otherwise
**********************************************************************

      LOGICAL FUNCTION ISINEL(X0,Y0,IEL,DCORVG,KVERT)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'

C parameters

      DOUBLE PRECISION X0,Y0
      INTEGER IEL
      DOUBLE PRECISION DCORVG(2,*)
      INTEGER KVERT(NNVE,*)

C local variables

      DOUBLE PRECISION DPROD
      DOUBLE PRECISION X(4),Y(4),XMID(4),YMID(4),XNRM(4),YNRM(4)
      DOUBLE PRECISION XDST(4),YDST(4)
      INTEGER IVE,IVE2,NVE
      LOGICAL BINSIDE

      NVE=4
      BINSIDE=.TRUE.

C     Fetch the corners of element IEL to local arrays X and Y:

      DO IVE=1,NVE
        X(IVE)=DCORVG(1,KVERT(IVE,IEL))
        Y(IVE)=DCORVG(2,KVERT(IVE,IEL))

C       If (X0,Y0) is a corner of the element, we can immediately
C       return TRUE.

        IF ((X(IVE).EQ.X0).AND.(Y(IVE).EQ.Y0)) THEN
          ISINEL = .TRUE.
          RETURN
        END IF
      END DO

C     Compute edge-midpoints and normal vectors to the four
C     edges on element IEL

      DO IVE=1,NVE

        IVE2=MOD(IVE,NVE)+1

C       compute midpoints of element edges

        XMID(IVE)=0.5D0*(X(IVE)+X(IVE2))
        YMID(IVE)=0.5D0*(Y(IVE)+Y(IVE2))

C       compute normal vectors to element edges

        XNRM(IVE)= Y(IVE2)-Y(IVE)
        YNRM(IVE)=-X(IVE2)+X(IVE)

C       compute vectors from edge midpoints to node 'ivt'

        XDST(IVE)=X0-XMID(IVE)
        YDST(IVE)=Y0-YMID(IVE)

      END DO

C     Check whether 'ivt' belongs to element 'iel' or not by
C     multiplying distance vectors with corresponding normal vectors.
C     The sign of this scalar product determines whether we are
C     'left' or 'right' of the edge (because of the cosine formula).
C     If the point is "righthand" of all four edges, it's inside
C     of the element.

      DO IVE=1,NVE
        DPROD = XDST(IVE)*XNRM(IVE)+YDST(IVE)*YNRM(IVE)
        BINSIDE = BINSIDE.AND.(DPROD.LE.1D-14)
      END DO

      ISINEL = BINSIDE

      END

**********************************************************************
* Returns .true. if the position (x0,y0) is in the element iel.
*
* This is similar to ISINEL, but uses a different approach.
* Calculates the area of a triangle [(x0,y0), corner i and corner i+1]
* of the quad. If the area is positive, the corners are arranged in a
* counterclockwise sense. If this is the case for all all four
* possible i's, the point is inside of the element.
*
* In:
*   X0,Y0  - Position of an arbitrary point
*   DCORVG - coordinates of all points
*   KVERT  - Vertex numbers on all elements
*   IEL    - Element number
*
* Result:
*   =true,  if (X0,Y0) is in element IEL
*   =false, otherwise
**********************************************************************

      LOGICAL FUNCTION ISINE2(X0,Y0,IEL,DCORVG,KVERT)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'

C parameters

      DOUBLE PRECISION X0,Y0,DCORVG
      INTEGER IEL,KVERT
      DIMENSION DCORVG(2,*),KVERT(NNVE,*)

C local variables

      DOUBLE PRECISION X,Y,DAREA
      DIMENSION X(4),Y(4)
      INTEGER IVE,IVE2,NVE

      NVE=4
      ISINE2 = .FALSE.

C     Fetch the corners of element IEL to local arrays X and Y:

      DO IVE=1,NVE
        X(IVE)=DCORVG(1,KVERT(IVE,IEL))
        Y(IVE)=DCORVG(2,KVERT(IVE,IEL))

C       If (X0,Y0) is a corner of the element, we can immediately
C       return TRUE.

        IF ((X(IVE).EQ.X0).AND.(Y(IVE).EQ.Y0)) THEN
          ISINE2 = .TRUE.
          RETURN
        END IF
      END DO

      DO IVE=1,NVE

        IVE2=MOD(IVE,NVE)+1
        DAREA=(X0-X(IVE))*(Y0+Y(IVE))+(X(IVE)-X(IVE2))*(Y(IVE)+Y(IVE2))
     *       +(X(IVE2)-X0)*(Y(IVE2)+Y0)

C       Cancel if one of the triangles has negative volume.

        IF (DAREA.LT.0D0) RETURN

      END DO

      ISINE2 = .TRUE.

      END

************************************************************************
* Calculate the intersection between two lines
*
* This routine calculates the intersection point (X,Y) of two
* lines [X1,Y1]->[X2,Y2] and [X3,Y3]->[X4,Y4].
*
* In:
*   X0,Y0
*   X1,Y1   - two different points on the first line
*   X2,Y2
*   Y3,Y3   - two different points on the second line
*
* Out:
*   X, Y    - Intersection point
*   IRES    - =0: There is an intersection point
*             =1: The two lines are identical; X,Y is undefined
*             =2: The two lines do not intersect; X,Y is undefined
************************************************************************

      SUBROUTINE LINSCT (X0,Y0,X1,Y1,X2,Y2,X3,Y3,X,Y,IRES)

      IMPLICIT NONE

      DOUBLE PRECISION X0,Y0,X1,Y1,X2,Y2,X3,Y3,X,Y
      INTEGER IRES

C     local variables

      DOUBLE PRECISION DET,A

      IRES = 0

C     We have (hopefully) the situation
C
C                    (X1,Y1)
C                       |
C                       |
C       (X2,Y2) --------+--------- (X3,Y3)
C                       |
C                       |
C                    (X0,Y0)
C
C      and want to calculate the intersection point. This means
C      we have to solve the linear system
C
C       ( X1-X0  X2-X3 ) * (a) = ( X2-X0 )
C       ( Y1-Y0  Y2-Y3 )   (b)   ( Y2-Y0 )
C
C      to get the "parameter" values a,b along the two lines where
C      the intersection occurres.
C
C      The determinant of the system is:

       DET = X1*Y2-X1*Y3-X0*Y2+X0*Y3-Y1*X2+Y1*X3+Y0*X2-Y0*X3

C      If it's =0, the lines are the same or completely different...

       IF (DET.EQ.0D0) THEN

C        If the vector (X2,Y2)->(X0,Y0) is linear dependent to
C        (X2,Y2)->(X3,Y3), the lines are the same.

          DET = -Y0*X2-X3*Y2+Y0*X3+X2*Y3+X0*Y2-X0*Y3
          IF (DET.EQ.0D0) THEN
            IRES = 1
          ELSE
            IRES = 2
          END IF

       ELSE

C       There is an intersection point. Calculate one of the
C       "parameter" values along the two lines.

        A = (Y0*X2+X3*Y2-Y0*X3-X2*Y3-X0*Y2+X0*Y3)/DET

C       The intersection point is then

        X = A*X1 + (1D0-A)*X0
        Y = A*Y1 + (1D0-A)*Y0

       END IF

      END

**********************************************************************
* Search for an element containing the point (x0,y0)
*
* Does a linear search on all elements until the one containing
* the position (x0,y0) is found.
*
* In:
*   X0,Y0  - Position of an arbitrary point
*   DCORVG - coordinates of all points
*   KVERT  - Vertex numbers on all elements
*   NEL    - Number of elements in the triangulation
*
* Out:
*   IEL    - Number of the element containing the point.
*            =0, if no element contains the point.
**********************************************************************

      SUBROUTINE PSRCH2(X0,Y0,DCORVG,KVERT,NEL,IEL)

      IMPLICIT NONE

      INCLUDE 'cbasicelem.inc'
      INCLUDE 'cbasictria.inc'

C parameters

      DOUBLE PRECISION X0,Y0
      INTEGER IEL,NEL

      DOUBLE PRECISION DCORVG(2,*)
      INTEGER KVERT(NNVE,*)

C local variables

      INTEGER JEL
      LOGICAL ISINEL

      DO JEL=1,NEL
        IF (ISINEL(X0,Y0,JEL,DCORVG,KVERT)) THEN
          IEL = JEL
          RETURN
        END IF
      END DO

      IEL = 0

      END

**********************************************************************
* Extended ray tracing element search
*
* Purpose: returns the element containing the point (x0,y0) by a
* raytracing method
* Constructs a ray from the old node position (whose element number
* is known) and traces it to the current position.
*
* In contrast to the standard version of the ray-tracing search,
* this routine does not completely stop the program if no element is
* found. Instead it will tell the caller what happened, i.e.:
* - if an element was found
* - if no element was found in the inner
* - if the point left the domain, through which boundary component
*   and which element
*
* In:
*  X0,
*  Y0     - Coordinates of the (moved) point to determine the element
*           number where this point resides in
*  IELOLD - Element in which the not-moved point (XALT,YALT)
*           resides in
*
* Out:
*  Return value:
*   = 0, if the element was found successfully. In this case:
*        IEL - Number of the element that contains (X0,Y0)
*   = 1, if the raytracing search broke down inside of the domain.
*        In this case:
*        IEL - last element that was analyzed
*   = 2, if the search broke down because the domain was left.
*        In this case:
*        IEL - last analyzed element where the ray left the domain
**********************************************************************

      INTEGER FUNCTION BSRCH4(X0,Y0,
     *                        DCORVG,KVERT,KADJ,
     *                        IELOLD,IEL)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'
      INCLUDE 'stria.inc'

      INTEGER MAXIT
      PARAMETER (MAXIT=100)

C parameters

      DOUBLE PRECISION X0,Y0,XALT,YALT
      DOUBLE PRECISION DCORVG(2,*)
      INTEGER KVERT,KADJ
      INTEGER IELOLD,IEL

      DIMENSION KVERT(NNVE,*),KADJ(NNVE,*)

C local variables

      DOUBLE PRECISION X1EDGE,Y1EDGE,X2EDGE,Y2EDGE
      INTEGER IVE,IDX,IELPRV
      LOGICAL BAUX,ISINE2,BINTSE

      IEL=IELOLD
      IELPRV=IELOLD

C     First a quick-check: If the point is in element IELOLD,
C     we are finished.

      IF ((IELOLD.NE.0).AND.(ISINE2(X0,Y0,IEL,DCORVG,KVERT))) THEN
        BSRCH4 = 0
        RETURN
      END IF

C     We restrict our raytracing search to 100 neighbour cells;
C     let's hope a point is not moved more than 100 elements in
C     one step...

      DO IDX=1,MAXIT

C       Calculate point of intersection with one of the four
C       surrounding edges, take the center of the starting element
C       as starting point  of the ray

        XALT=0.5D0*(DCORVG(1,KVERT(1,IEL))+DCORVG(1,KVERT(3,IEL)))
        YALT=0.5D0*(DCORVG(2,KVERT(1,IEL))+DCORVG(2,KVERT(3,IEL)))

C       Check all edges to find an intersection point:

        DO IVE=1,NNVE

C         don't jump back to the old element

          IF (KADJ(IVE,IEL).NE.IELPRV) THEN
            X1EDGE=DCORVG(1,KVERT(IVE,IEL))
            Y1EDGE=DCORVG(2,KVERT(IVE,IEL))
            X2EDGE=DCORVG(1,KVERT(MOD(IVE,NNVE)+1,IEL))
            Y2EDGE=DCORVG(2,KVERT(MOD(IVE,NNVE)+1,IEL))
            BAUX=BINTSE(XALT,YALT,X0,Y0,X1EDGE,Y1EDGE,X2EDGE,Y2EDGE)

C           BAUX is TRUE if we found a point of intersection.

            IF (BAUX) THEN

C             Go on searching in the neighbour element

              IELPRV=IEL

C             Stop here if we leave our domain. To test that use the
C             fact that KADJ()=0 if there is no neighbour element!
C             The caller can use IEL to find out the information
C             about the boundary where the domain was left...

              IF (KADJ(IVE,IELPRV).EQ.0) THEN
                BSRCH4 = 2
                RETURN
              END IF

              IEL=KADJ(IVE,IELPRV)
              GOTO 210

            END IF

          END IF

        END DO ! IVE

C       We can't find a point of intersection!
C       This means, the line segment from the element midpoint
C       to the target mitpoint does not leave out element -
C       or in other words: we found the element that contains
C       the point!

C        IF (ISINE2(X0,Y0,IEL,DCORVG,KVERT)) THEN
          BSRCH4 = 0
          RETURN
C        ELSE
C          WRITE (*,*) 'BSRCH4: Can''t find point in element!?!'
C        END IF

210     CONTINUE

      END DO

C If the search is successful, we cancel the DO-loop and jump out
C of this routine; otherwise we end up here because we have not
C been able to find the element that contains the point...

      BSRCH4 = 1

      END

**********************************************************************
* Extended ray tracing element search
*
* Purpose: returns the element containing the point (x0,y0) by a
* raytracing method.
* Constructs a ray from the old node position (whose element number
* is known) and traces it to the current position.
*
* This routine works very similar to BSRCH4. It has the following
* differences:
*  - It's a subroutine, not a function
*  - When the domain is left, the routine reports
*    - through which element the domain was left
*    - through which edge the domain was left
*
* In:
*  X0,
*  Y0     - Coordinates of the (moved) point to determine the element
*           number where this point resides in
*  IELOLD - Element in which the not-moved point (XALT,YALT)
*           resides in
*  DCORVG,
*  KVERT,
*  KMID,
*  KADJ,
*  NVT    - Usual geometry quantities
*
* Out:
*  IRES = 0, if the element was found successfully. In this case:
*            IEL  - Number of the element that contains (X0,Y0)
*            IEDG = 0
*            X1 = Y1 = X2 = Y2 = 0
*       = 1, if the raytracing search broke down inside of the domain.
*            In this case:
*            IEL - last element that was analyzed
*            IEDG = 0
*            X1 = Y1 = X2 = Y2 = 0
*       = 2, if the search broke down because the domain was left.
*            In this case:
*            IEL  - last analyzed element where the ray left
*                   the domain
*            IEDG - Global number of the edge through which the domain
*                   was left; the value is i the range 1..NMT
*            X1,Y1 - starting point of the edge through which the
*                    domain was left
*            X2,Y2 - ending point of the edge through which the
*                    domain was left
**********************************************************************

      SUBROUTINE PSRCH4(X0,Y0,
     *                  DCORVG,KVERT,KMID,KADJ,NVT,
     *                  IELOLD,IEL,
     *                  IRES,IEDG,X1,Y1,X2,Y2)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'
      INCLUDE 'stria.inc'

      INTEGER MAXIT
      PARAMETER (MAXIT=100)

C parameters

      DOUBLE PRECISION X0,Y0,XALT,YALT,X1,Y1,X2,Y2
      DOUBLE PRECISION DCORVG(2,*)
      INTEGER IELOLD,IEL,IRES,IEDG

      INTEGER KVERT(NNVE,*),KADJ(NNVE,*),KMID(NNVE,*),NVT

C local variables

      DOUBLE PRECISION X1EDGE,Y1EDGE,X2EDGE,Y2EDGE
      INTEGER IVE,IDX,IELPRV
      LOGICAL BAUX,ISINE2,BINTSE

      IEL=IELOLD
      IELPRV=IELOLD

C     Initialise output variables

      IRES = 0
      IEDG = 0
      X1 = 0
      Y1 = 0
      X2 = 0
      Y2 = 0

C     First a quick-check: If the point is in element IELOLD,
C     we are finished.

      IF ((IELOLD.NE.0).AND.(ISINE2(X0,Y0,IEL,DCORVG,KVERT))) THEN
        RETURN
      END IF

C     We restrict our raytracing search to 100 neighbour cells;
C     let's hope a point is not moved more than 100 elements in
C     one step...

      DO IDX=1,MAXIT

C       Calculate point of intersection with one of the four
C       surrounding edges, take the center of the starting element
C       as starting point  of the ray

        XALT=0.5D0*(DCORVG(1,KVERT(1,IEL))+DCORVG(1,KVERT(3,IEL)))
        YALT=0.5D0*(DCORVG(2,KVERT(1,IEL))+DCORVG(2,KVERT(3,IEL)))

C       Check all edges to find an intersection point:

        DO IVE=1,NNVE

C         don't jump back to the old element

          IF (KADJ(IVE,IEL).NE.IELPRV) THEN
            X1EDGE=DCORVG(1,KVERT(IVE,IEL))
            Y1EDGE=DCORVG(2,KVERT(IVE,IEL))
            X2EDGE=DCORVG(1,KVERT(MOD(IVE,NNVE)+1,IEL))
            Y2EDGE=DCORVG(2,KVERT(MOD(IVE,NNVE)+1,IEL))
            BAUX=BINTSE(XALT,YALT,X0,Y0,X1EDGE,Y1EDGE,X2EDGE,Y2EDGE)

C           BAUX is TRUE if we found a point of intersection.

            IF (BAUX) THEN

C             Go on searching in the neighbour element

              IELPRV=IEL

C             Stop here if we leave our domain. To test that use the
C             fact that KADJ()=0 if there is no neighbour element!
C             The caller can use IEL to find out the information
C             about the boundary where the domain was left...

              IF (KADJ(IVE,IELPRV).EQ.0) THEN

                IRES = 2

C               What's the edge where we left the domain?

                IEDG = KMID(IVE,IELPRV)-NVT

C               Which start/endpoint does this edge have?

                X1 = DCORVG(1,KVERT(IVE,IELPRV))
                Y1 = DCORVG(2,KVERT(IVE,IELPRV))
                X2 = DCORVG(1,KVERT(MOD(IVE,4)+1,IELPRV))
                Y2 = DCORVG(2,KVERT(MOD(IVE,4)+1,IELPRV))

                RETURN

              END IF

              IEL=KADJ(IVE,IELPRV)
              GOTO 210

            END IF

          END IF

        END DO ! IVE

C       We can't find a point of intersection!
C       This means, the line segment from the element midpoint
C       to the target mitpoint does not leave out element -
C       or in other words: we found the element that contains
C       the point!

C        IF (ISINE2(X0,Y0,IEL,DCORVG,KVERT)) THEN
          IRES = 0
          RETURN
C        ELSE
C          WRITE (*,*) 'BSRCH4: Can''t find point in element!?!'
C        END IF

210     CONTINUE

      END DO

C If the search is successful, we cancel the DO-loop and jump out
C of this routine; otherwise we end up here because we have not
C been able to find the element that contains the point...

      IRES = 1

      END

**********************************************************************
* Hierarchical element search
*
* This routine uses a hierarchical search to find the element number
* that contains a point (X0,Y0). The caller can specify a start-
* and an end-level where to search. Inside of each level, a raytracing
* technique is used to find the element.
* The caller can specify an element on the start-level where to start
* the search. If no element is specified, a linear search will be done
* on all elements on the start-level to find the initial element.
*
* In:
*   TRIAS  - array [1..SZTRIA,1..*] of integer
*            Triangulation structures on all relevant levels.
*   ILVMIN - Minimum level where to start the search
*   ILVMAX - Maximum level where to find the element number
*   X0,Y0  - Coordinates of the point that is to be searched
*   IELOLD - Initial element number on level ILVMIN where to start
*            the search.
*            =0, if the initial element number is unknown.
*
* Out:
*   IEL    - Element number on level ILVMAX that contains the
*            point (X0,Y0);
*            =0, if the element could not be found.
*
* Remark, IELOLD=IEL on call of the routine is allowed.
**********************************************************************

      SUBROUTINE PSRCH5(TRIAS,ILVMIN,ILVMAX,X0,Y0,IELOLD,IEL)

      IMPLICIT NONE

      INCLUDE 'cmem.inc'

      INCLUDE 'stria.inc'

C     parameters

      INTEGER TRIAS(SZTRIA,*),ILVMIN,ILVMAX,IEL,IELOLD
      DOUBLE PRECISION X0,Y0

C     externals

      INTEGER BSRCH4
      EXTERNAL BSRCH4

C     local variables

      INTEGER ILEV,IELTMP

      IEL = IELOLD

C     If the initial element number is unknown...

      IF (IEL.LE.0) THEN

C       Try to make a raytracing search from element number 1.

        IELTMP = 1
        IF (BSRCH4(X0,Y0,
     *             DWORK(L(TRIAS(OLCORVG,ILVMIN))),
     *             KWORK(L(TRIAS(OLVERT,ILVMIN))),
     *             KWORK(L(TRIAS(OLADJ,ILVMIN))),
     *             IELTMP,IEL).NE.0) THEN

C         Oops, raytracing failed.
C         Set the element number back to 0. The loop
C         will then make a linear search through all
C         elements to find one that contains the point.

          IEL = 0

        END IF ! BSRCH4 <> 0

C       If an element is found, good - then we save a (costly)
C       linear search!

      END IF ! IEL = 0

      DO ILEV=ILVMIN,ILVMAX

C       Detetmine the initial element that contains the point.
C       If the element is given, ok. If not, make a linear search
C       on the coarsest level to find it.

        IF (IEL.EQ.0) THEN
          CALL PSRCH2(X0,Y0,DWORK(L(TRIAS(OLCORVG,ILEV))),
     *                KWORK(L(TRIAS(OLVERT,ILEV))),TRIAS(ONEL,ILEV),
     *                IEL)

          IF (IEL.EQ.0) THEN

C           Oops, linear search failed. Then we start at element 1.
C           Don't stop here, as in "circle" domains it may happen that
C           the point on the higher level is in the domain while
C           the point on the lower level is not!
C           Let's hope that the domain is somehow convex so that
C           raytracing works...

            IEL = 1

          END IF
        END IF

C       Start the raytracing technique to find a better element

        IELTMP = IEL
        IF (BSRCH4(X0,Y0,
     *             DWORK(L(TRIAS(OLCORVG,ILEV))),
     *             KWORK(L(TRIAS(OLVERT,ILEV))),
     *             KWORK(L(TRIAS(OLADJ,ILEV))),
     *             IELTMP,IEL).NE.0) THEN

C         Oops, raytracing failed.
C         Set the element number back to 0 and start on the
C         next higher level with a linear search

          IEL = 0

        END IF ! BSRCH4 <> 0

C       Otherwise: Element number of lower level found.
C       Take this as initial element on the higher level.
C       Because of the 2-level ordering, this element
C       number is usually near to the element on the finer
C       level containing that point!

      END DO ! ILEV

C     If IEL<>0, this is the last element number on the highest
C     level that contains (X0,Y0)!

      END