C++***************************************************************
C Program to compute FFT_1D
C Calling FFT1 (either in "fft_nag.for" or "fft_jlp.for")
C WARNING: NAG FFT divides the result by SQRT(NX)
C
C JLP
C Version of 26-09-95
C--***************************************************************
        PROGRAM FFT1
        INTEGER*4 PNTR_RE, PNTR_IM, MADRID(1)
        INTEGER KOD
        CHARACTER NAME*40,COMMENTS*80,ANS*1
        COMMON /VMR/MADRID

        CALL JLP_BEGIN

C Inquire the format (input/output) :
        CALL JLP_INQUIFMT

C Option:
19      WRITE(6,15)
15      FORMAT(' Options: ',/,
     1      ' 1=direct FFT (in/out: real,imaginary)',/,
     1      ' 2=direct FFT (in: real,ima /out: power,phase)',/,
     1      ' -1=inverse FFT (in/out: real,imaginary)',/,
     1      ' -2=inverse FFT (in: power,phase /out: real,ima)',/,
     1      ' Enter your choice:')
      READ(5,*) KOD
      IF((IABS(KOD).NE.1).AND.(IABS(KOD).NE.2))THEN
         WRITE(6,17)
17         FORMAT(' Error: enter again the option')
         GOTO 19
      ENDIF

C Input :
      WRITE(6,*)' Input image (real part):'
      READ(5,10) NAME
      CALL JLP_VM_READIMAG(PNTR_RE,NX,NY,NAME,COMMENTS)
        IF(KOD.EQ.-1)THEN
       CALL RECENT_FFT_1D_Y_FLOAT(MADRID(PNTR_RE),MADRID(PNTR_RE),
     1                              NX,NY,NX)
        ENDIF

C Imaginary part:
        IF(KOD.NE.-2) THEN
          WRITE(6,22)
22        FORMAT(' Input image (imaginary part):',/,
     1      ' Null imaginary part? (N) ?')
        ELSE
          WRITE(6,23)
23        FORMAT(' Input image (phase):',/,
     1      ' Null phase? (N) ?')
        ENDIF
C
        READ(5,10) ANS
10        FORMAT(A)

      IF(ANS.NE.'Y'.AND.ANS.NE.'y')THEN
        READ(5,10) NAME
        CALL JLP_VM_READIMAG(PNTR_IM,NX1,NY1,NAME,COMMENTS)
          IF(KOD.EQ.-1)THEN
        CALL RECENT_FFT_1D_Y_FLOAT(MADRID(PNTR_IM),MADRID(PNTR_IM),
     1                               NX1,NY1,NX1)
          ENDIF
C Check the size:
        IF((NX1.NE.NX).OR.(NY1.NE.NY))THEN
          WRITE(6,21)
21         FORMAT(' FATAL ERROR: Wrong size for the input images',/,
     1      ' (should be the same for the real/imaginary parts)')
          GOTO 999
        ENDIF
      ELSE
          CALL JLP_GETVM(PNTR_IM,NX*NY*4)
          CALL ZERO(MADRID(PNTR_IM),NX,NY)
      ENDIF

C FFT:
      WRITE(6,*) ' Start FFT'
      CALL FFT_1D(MADRID(PNTR_RE),MADRID(PNTR_IM),NX,NY,NX,KOD)
      WRITE(6,*) ' FFT OK'

C Output :
      WRITE(6,*)' Real part / Power spect.:'
      READ(5,10) NAME
      CALL RECENT_FFT_1D_Y_FLOAT(MADRID(PNTR_RE),MADRID(PNTR_RE),
     1                             NX,NY,NX)
      CALL JLP_WRITEIMAG(MADRID(PNTR_RE),NX,NY,NX,NAME,COMMENTS)

      WRITE(6,*)' Imaginary part / Phase:'
      READ(5,10) NAME
      CALL RECENT_FFT_1D_Y_FLOAT(MADRID(PNTR_IM),MADRID(PNTR_IM),
     1                             NX,NY,NX)
      CALL JLP_WRITEIMAG(MADRID(PNTR_IM),NX,NY,NX,NAME,COMMENTS)

999      CALL JLP_END
      STOP
      END
C****************************************************************
        SUBROUTINE ZERO(ARRAY,NX,NY)
        REAL ARRAY(NX,NY)
        DO J=1,NY
         DO I=1,NX
          ARRAY(I,J)=0.
         ENDDO
        ENDDO
        RETURN
        END
C****************************************************************
C      include 'fft:fft_nag.for'
C      include 'fft:fft_jlp.for'


! program to time the various routines
subroutine f_main

  use ddmodule
  implicit none
  integer*4 old_cw
  double precision t
  double precision second
  double precision time_thresh
  parameter (time_thresh = 0.5d0)
  type (dd_real) a, b, c, d
  integer n, i, k

  call f_fpu_fix_start (old_cw)

  write (6, *) 'Timing addition / subtraction ...'
  n = 512
  do k = 1, 25
    n = n * 2
    a = ddpi()
    b = sqrt(a)
    c = sqrt(b)
    d = sqrt(c)
    t = second()
    do i = 1, n
      a = b + c
      b = a - d
      a = b + c
      b = a - d
    enddo
    t = second() - t
    if (t .ge. time_thresh) exit
  enddo
  n = n * 4
  write (6, *) n, ' operations in ', t, ' seconds.'
  write (6, *) t/n*1.0d6, ' usec'
  call ddwrite(6, a)

  write (6, *) 'Timing multiplication ...'
  n = 512
  do k = 1, 25
    n = n * 2
    a = 1.0d0 + ddpi() * 1.0d-7
    b = a + 1.0d-7
    c = b + 1.0d-8
    d = c + 1.0d-9
    t = second()
    do i = 1, n
      a = b * c
      b = a * d
      a = b * c
      b = a * d
    enddo
    t = second() - t
    if (t .ge. time_thresh) exit
  enddo
  n = n * 4
  write (6, *) n, ' operations in ', t, ' seconds.'
  write (6, *) t/n*1.0d6, ' usec'
  call ddwrite(6, a)

  write (6, *) 'Timing division ...'
  n = 512
  do k = 1, 25
    n = n * 2
    a = 1.0d0 + ddpi()
    b = 2.0d0 + ddpi()
    c = 1.0d0 + 1.0d-8
    d = 1.0d0 + 1.0d-9
    t = second()
    do i = 1, n
      a = b / c
      b = a / d
      a = b / c
      b = a / d
    enddo
    t = second() - t
    if (t .ge. time_thresh) exit
  enddo
  n = n * 4
  write (6, *) n, ' operations in ', t, ' seconds.'
  write (6, *) t/n*1.0d6, ' usec'
  call ddwrite(6, a)

  write (6, *) 'Timing square root ...'
  n = 512
  do k = 1, 25
    n = n * 2
    a = 0.0d0
    b = 2.0d0 + ddpi()
    t = second()
    do i = 1, n
      a = sqrt(a + b)
    enddo
    t = second() - t
    if (t .ge. time_thresh) exit
  enddo
  write (6, *) n, ' operations in ', t, ' seconds.'
  write (6, *) t/n*1.0d6, ' usec'
  call ddwrite(6, a)

  write (6, *) 'Timing sin ...'
  n = 512
  do k = 1, 25
    n = n * 2
    a = 0.0d0
    c = 1.7d0 * ddreal(1.0d0) / dble(n)
    d = 2.45d0 * ddpi() / dble(n + 3)
    t = second()
    do i = 1, n
      a = a + sin(c)
      c = c + d
    enddo
    t = second() - t
    if (t .ge. time_thresh) exit
  enddo
  write (6, *) n, ' operations in ', t, ' seconds.'
  write (6, *) t/n*1.0d6, ' usec'
  call ddwrite(6, a)

  write (6, *) 'Timing log ...'
  n = 512
  do k = 1, 25
    n = n * 2
    a = 0.0d0
    c = exp(ddreal(-50.1d0));
    d = exp(ddreal(100.2d0) / dble(n))
    t = second()
    do i = 1, n
      a = a + log(c)
      c = c * d
    enddo
    t = second() - t
    if (t .ge. time_thresh) exit
  enddo
  write (6, *) n, ' operations in ', t, ' seconds.'
  write (6, *) t/n*1.0d6, ' usec'
  call ddwrite(6, a)

end


C FILE: 'init_seed_linux.f'
C ---------------------------------------------------------------------
C
C       Seeding function for UNIX FORTRAN random number generators
C
C          The integer function SEED returns the product of the number
C     of minutes and seconds of the system clock, to serve as seed
C     for the random number generating functions: IRAND, RAND, and
C     DRAND.
C
C     Note: this function uses the UNIX FORTRAN library function
C           TIME to get the system time.
C
C     Command Syntax:  This function should be called as the
C                      argument to one of the system random
C                      number functions.  For example to seed
C                      the function RAND, the following command
C                      should be used:
C
C                              MUMBLE = RAND( SEED() )
C
C                      REMEMBER that SEED and RAND (or IRAND or DRAND)
C                      must be declared in your calling routine!
C
C
C   Variables used:
C        INIT = Logical flag which is true only on the first call to
C               SEED.
C
C        OLDSED = Previous value of the SEED function.
C
C ---------------------------------------------------------------------

      INTEGER FUNCTION INIT_SEED_LINUX()

      INTEGER TIME, IRAND, OLDSED
      LOGICAL INIT
      SAVE INIT, OLDSED
C    Initialize flag INIT to be true on the first run only.
      DATA INIT /.TRUE./

      IF (INIT) THEN
C        Call system function that returns time since 00:00 GMT 1/1/1970
C        and use that as an initial seed.
           OLDSED = TIME()
      ELSE
C         Else use old seed as to seed the next value.
           OLDSED = IRAND(OLDSED)
      ENDIF

C    Reset INIT to be false on any later calls to SEED
      INIT = .FALSE.

      INIT_SEED_LINUX = OLDSED
      RETURN
      END


      FUNCTION IFXY(ADSC)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    IFXY
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS FUNCTION RETURNS THE INTEGER CORRESPONDING TO THE
C   BIT-WISE REPRESENTATION OF AN INPUT CHARACTER FXY VALUE OF LENGTH
C   SIX.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C                           DOCUMENTATION
C
C USAGE:    IFXY (ADSC)
C   INPUT ARGUMENT LIST:
C     ADSC     - CHARACTER*6: CHARACTER FORM OF DESCRIPTOR (FXY VALUE)
C
C   OUTPUT ARGUMENT LIST:
C     IFXY     - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY)
C                VALUE
C
C REMARKS:
C
C      EXAMPLE:
C
C      If ADSC = '063022', then IFXY = 16150 since:
C
C      0       63           22
C
C      F |     X     |       Y
C        |           |
C     0 0 1 1 1 1 1 1 0 0 0 1 0 1 1 0  =
C
C      ( 2**13 + 2**12 + 2**11 + 2**10 +
C              2**9 + 2**8 + 2**4 + 2**2 + 2**1 )  = 16150
C
C
C    THIS ROUTINE CALLS:        None
C    THIS ROUTINE IS CALLED BY: BFRINI   DXINIT   GETNTBE  IDN30
C                               NEMTAB   NEMTBB   NEMTBD   NUMTBD
C                               RESTD    SNTBDE   STBFDX   STNTBI
C                               STSEQ    UFBQCP
C                               Normally not called by any application
C                               programs but it could be.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      CHARACTER*6 ADSC

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      READ(ADSC,'(I1,I2,I3)') IF,IX,IY
      IFXY = IF*2**14 + IX*2**8 + IY
      RETURN
      END


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   Intrinsic names passed as arguments.
*   (all intrinsics which are allowed to be passed are tested once).

	parameter(n = 55)
	implicit real*8 (d)
	integer rslts(n), expect(n)

	intrinsic aint, anint, abs, sqrt, exp, alog, alog10, sin,
     +            cos, tan, asin, acos, atan, sinh, cosh, tanh,
     +            dint, dnint, dabs, dsqrt, dexp, dlog, dlog10,
     +            dsin, dcos, dtan, dasin, dacos, datan, dsinh,
     +            dcosh, dtanh, nint, idnint, dprod, len, index,
     +            aimag
	integer ctoi
	intrinsic conjg, csqrt, cexp, clog, csin, ccos
	intrinsic sign, dsign, dim, ddim, atan2, datan2
	intrinsic cabs, iabs, mod, isign, idim

c --- tests 1 - 16: intrinsics which take 1 REAL arg and return REAL:

	rslts(1) = f1(aint, 2.9)
	rslts(2) = f1(anint, 2.9)
	rslts(3) = f1(abs, -6.0)
	rslts(4) = f1(sqrt, 16.1)
	rslts(5) = f1(exp, 0.0)
	rslts(6) = f1(alog, exp(5.1))
	rslts(7) = f1(alog10, 1000.1)
	rslts(8) = f1(sin, 1.0) * 100
	rslts(9) = f1(cos, 2.0) * 100
	rslts(10) = f1(tan, 3.0) * 100
	rslts(11) = f1(asin, 0.5) * 100
	rslts(12) = f1(acos, -.5) * 100
	rslts(13) = f1(atan, 5.0) * 100
	rslts(14) = f1(sinh, .5) * 100
	rslts(15) = f1(cosh, 1.0) * 100
	rslts(16) = f1(tanh, 2.0) * 100

c --- tests 17 - 32: intrinsics which take 1 d.p. arg and return d.p.:

	rslts(17) = df1(dint, 2.9d0)
	rslts(18) = df1(dnint, 2.9d0)
	rslts(19) = df1(dabs, -6.0d0)
	rslts(20) = df1(dsqrt, 16.1d0)
	rslts(21) = df1(dexp, 0.0d0)
	rslts(22) = df1(dlog, dexp(5.1d0))
	rslts(23) = df1(dlog10, 1000.1d0)
	rslts(24) = df1(dsin, 1.0d0) * 100
	rslts(25) = df1(dcos, 2.0d0) * 100
	rslts(26) = df1(dtan, 3.0d0) * 100
	rslts(27) = df1(dasin, 0.5d0) * 100
	rslts(28) = df1(dacos, -.5d0) * 100
	rslts(29) = df1(datan, 5.0d0) * 100
	rslts(30) = df1(dsinh, .5d0) * 100
	rslts(31) = df1(dcosh, 1d0) * 100
	rslts(32) = df1(dtanh, 2d0) * 100

c  --- tests 33 - 38: miscellaneous intrinsics:

	call sub1(nint, 2.9, idnint, -2.9d0, rslts)

	call sub2(rslts, dprod, len, index, aimag)

c  --- tests 39 - 44: complex intrinsics:

	rslts(39) = ctoi((1, 2), conjg)
	rslts(40) = ctoi((2, -3), csqrt)
	rslts(41) = ctoi((-1, 1), cexp)
	rslts(42) = ctoi((3, 4), clog)
	rslts(43) = ctoi((3, 4), csin)
	rslts(44) = ctoi((3, 4), ccos)

c  --- tests 45 - 50: 2 argument real and d.p. intrinsics:

	call sub3(sign, dsign, rslts(45))
	call sub3(dim, ddim, rslts(47))
	call sub3(atan2, datan2, rslts(49))

c  --- tests 51 - 55:  cabs, iabs, mod, isign, idim.

	call sub4(rslts, cabs, iabs, mod, isign, idim)

c  --- check results:

	call check(rslts, expect, n)

	data expect /2, 3, 6, 4, 1, 5, 3, 84, -41, -14, 52, 209,
     +                              137, 52, 154, 96,
     +               2, 3, 6, 4, 1, 5, 3, 84, -41, -14, 52, 209,
     +                              137, 52, 154, 96,
     +               3, -3, 10000, 3, 3, 10,
     +               980, 1665, 201, 1618, 3583, -27073,
     +               -23, -23, 33, 33, 19, 19,
     +               5, 4, 3, 3, 0                          /
	end

c ccccccccccccccccccccccccccccccccccccccccccccccccccccccc

	real function f1(f, a)
	f1 = f(a)
	end

	function df1(f, d)
	implicit real*8 (d-f)
	external f
	df1 = f(d)
	return
	end

	subroutine sub1(i, x, j, d, a)
	integer a(*), i
	real*8 d

	a(33) = i(x)
	a(34) = j(d)
	end

	subroutine sub2(a, dp, le, in, ai)
	integer a(1:*)
	external dp, ai
	double precision dp
        interface
           integer function le (string)
           character*(*) :: string
           end function le
           integer function in (string, substring)
           character*(*) :: string, substring
           end function in
        end interface

	a(35) = dp(100., 100.)
	a(36) = le('abc')
	a(37) = in('abcd', 'c')
	a(38) = ai( (2.0, 10.1) )

	end

	integer function ctoi(c, f)
	complex c, f, t
	external f

	t = f(c)
	ctoi = real(t) * 1000 + aimag(t) * 10
	end

	subroutine sub3(rf, df, a)
	integer a(*)
	real rf
	real*8 df
	external rf, df
	a(1) = rf(2.31, -1.0) * 10
	a(2) = df(2.31d0, -1.0d0) * 10
	end

	subroutine sub4(a, cabs, iabs, mod, isign, idim)
	external cabs, iabs, mod, isign, idim
	real cabs
	integer mod, iabs, isign, idim, a(*)

	a(51) = cabs((3.1, 4.0))
	a(52) = iabs(-4)
	a(53) = mod(7, 4)
	a(54) = isign(3, 0)
	a(55) = idim(3, 4)
	end


module yf_all
	! contains functions that compute the yield functions of the material model
	! and one main (model-indepenent) function that calls all yield functions of the model
	! and returns the function values as a vector

	use constants
	use material_info
	use derived_types

    implicit none

contains

	function yf(sigma, alpha)
		! computes all yield function values for the given model
		! and returns them as real 1D array
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha							! internal variables vector

		! return variable
		real(kind=dbl), dimension(n_yf) :: yf					! array for yield function values

		! internal variables
		! --------------------------------------------------------------------------

		! --------------------------------------
		! computation of each yield function (modified leon, ...)
		! returning yield functions in yield_function vector
		! --------------------------------------

		yf(1) = yf_1(sigma, alpha)

	end function yf

	function yf_ret_map(sigma, alpha, yield_flags)
		! computes yield function values for the given model
		! based on the entries of the yield flags vector
		! and returns them as real 1D array
		! if the yield function isn't active the corresponding yield function value won't be computed
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma			! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha			! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags			! active yield functions vector

		! return variable
		real(kind=dbl), dimension(n_yf) :: yf_ret_map				! array for yield function values

		! internal variables
		! --------------------------------------------------------------------------

		! --------------------------------------
		! computation of each yield function (modified leon, ...)
		! --------------------------------------

		!write(*,*) size(yield_function)

		if (yield_flags(1) .eqv. .false.) then			! first yield function is active

			! call first yield function (modified leon)
			! and assign its value to first line of yield function return vector
			!yf_1 = yf_modleon( sigma, alpha, mat_data)
			yf_ret_map(1) = yf_1(sigma, alpha)

		end if

!		if (yield_flags(2) .eqv. .false.) then			! second yield function is active
!
!			! call second yield function (modified leon cut off)
!			! and assign its value to second line of yield function return vector
!			!yf_2 = yf_cutoff_modleon(sigma, alpha, mat_data)
!			yf_ret_map(2) = yf_2(sigma, alpha)
!
!		end if

	end function yf_ret_map

	function yf_1(sigma, alpha)
		! computes the first yield function
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl) :: yf_1

		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha		! internal variable vector

		! internal variables
		real(kind=dbl), dimension(6) :: struc_vec				! transversely isotropic tsai-wu structural vector
		real(kind=dbl), dimension(6,6) :: struc_matrix			! transversely isotropic tsai-wu structural matrix
		! --------------------------------------------------------------------------

		! compute structural vector and matrix
		call comp_tsaiwu_tensors(struc_vec, struc_matrix)

		! compute tsai-wu yield function
		yf_1 = dot_product(struc_vec, sigma) + dot_product(matmul(struc_matrix, sigma), sigma) - 1._dbl

	end function yf_1

	subroutine comp_tsaiwu_tensors(struc_vec, struc_matrix)
		! computes the tsai-wu structural vector and matrix
		! for the transversely isotropic case
		! from the model parameters imported via the derived_types module
		implicit none

		! --------------------------------------------------------------------------
		! return variables
		real(kind=dbl), dimension(:), intent(out) :: struc_vec
		real(kind=dbl), dimension(:,:), intent(out) :: struc_matrix
		! --------------------------------------------------------------------------

		struc_vec = (/ mat_pars%F2, mat_pars%F2, mat_pars%F3, &
						0._dbl, 0._dbl, 0._dbl /)

		struc_matrix = reshape( (/mat_pars%F22, mat_pars%F12, mat_pars%F23, 0._dbl, 0._dbl, 0._dbl, &
								  mat_pars%F12, mat_pars%F22, mat_pars%F23, 0._dbl, 0._dbl, 0._dbl, &
								  mat_pars%F23, mat_pars%F23, mat_pars%F33, 0._dbl, 0._dbl, 0._dbl, &
								  0._dbl, 0._dbl, 0._dbl, mat_pars%F44, 0._dbl, 0._dbl, &
								  0._dbl, 0._dbl, 0._dbl, 0._dbl, mat_pars%F44, 0._dbl, &
								  0._dbl, 0._dbl, 0._dbl, 0._dbl, 0._dbl, 2._dbl*(mat_pars%F22-mat_pars%F12)/), &
							   (/6,6/) )

	end subroutine comp_tsaiwu_tensors

end module yf_all


module centered_helmholtz_solvers

    use fishpack_precision, only: &
        wp, & ! Working precision
        ip, & ! Integer precision
        PI, &
        TWO_PI

    use type_FishpackWorkspace, only: &
        FishpackWorkspace

    use type_CenteredCyclicReductionUtility, only: &
        CenteredCyclicReductionUtility

    use type_GeneralizedCyclicReductionUtility, only:&
        GeneralizedCyclicReductionUtility

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: hwscrt ! Centered cartesian solver
    public :: hwsplr ! Centered polar solver
    public :: hwscyl ! Centered cylindrical solver
    public :: hwsssp ! Centered spherical solver
    public :: hwscsp ! Centered axisymmetric spherical solver

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: HALF = 0.5_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp

    ! Declare module subroutine interfaces
    interface
        module subroutine hwscrt(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
            bdd, elmbda, f, idimf, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)     :: m
            integer(ip), intent(in)     :: mbdcnd
            integer(ip), intent(in)     :: n
            integer(ip), intent(in)     :: nbdcnd
            integer(ip), intent(in)     :: idimf
            integer(ip), intent(out)    :: ierror
            real(wp),    intent(in)     :: a
            real(wp),    intent(in)     :: b
            real(wp),    intent(in)     :: c
            real(wp),    intent(in)     :: d
            real(wp),    intent(in)     :: elmbda
            real(wp),    intent(out)    :: pertrb
            real(wp),    intent(in)     :: bda(:)
            real(wp),    intent(in)     :: bdb(:)
            real(wp),    intent(in)     :: bdc(:)
            real(wp),    intent(in)     :: bdd(:)
            real(wp),    intent(inout)  :: f(:,:)
        end subroutine hwscrt

        module subroutine hwsplr(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
            bdd, elmbda, f, idimf, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)     :: m
            integer(ip), intent(in)     :: mbdcnd
            integer(ip), intent(in)     :: n
            integer(ip), intent(in)     :: nbdcnd
            integer(ip), intent(in)     :: idimf
            integer(ip), intent(out)    :: ierror
            real(wp),    intent(in)     :: a
            real(wp),    intent(in)     :: b
            real(wp),    intent(in)     :: c
            real(wp),    intent(in)     :: d
            real(wp),    intent(in)     :: elmbda
            real(wp),    intent(out)    :: pertrb
            real(wp),    intent(in)     :: bda(:)
            real(wp),    intent(in)     :: bdb(:)
            real(wp),    intent(in)     :: bdc(:)
            real(wp),    intent(in)     :: bdd(:)
            real(wp),    intent(inout) :: f(:,:)
        end subroutine hwsplr

        module subroutine hwscyl(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
            bdd, elmbda, f, idimf, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)    :: m
            integer(ip), intent(in)    :: mbdcnd
            integer(ip), intent(in)    :: n
            integer(ip), intent(in)    :: nbdcnd
            integer(ip), intent(in)    :: idimf
            integer(ip), intent(out)   :: ierror
            real(wp),    intent(in)    :: a
            real(wp),    intent(in)    :: b
            real(wp),    intent(in)    :: c
            real(wp),    intent(in)    :: d
            real(wp),    intent(in)    :: elmbda
            real(wp),    intent(out)   :: pertrb
            real(wp),    intent(in)    :: bda(:)
            real(wp),    intent(in)    :: bdb(:)
            real(wp),    intent(in)    :: bdc(:)
            real(wp),    intent(in)    :: bdd(:)
            real(wp),    intent(inout) :: f(:,:)
        end subroutine hwscyl

        module subroutine hwsssp(ts, tf, m, mbdcnd, bdts, bdtf, ps, pf, n, nbdcnd, &
            bdps, bdpf, elmbda, f, idimf, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)     :: m
            integer(ip), intent(in)     :: mbdcnd
            integer(ip), intent(in)     :: n
            integer(ip), intent(in)     :: nbdcnd
            integer(ip), intent(in)     :: idimf
            integer(ip), intent(out)    :: ierror
            real(wp),    intent(in)     :: ts
            real(wp),    intent(in)     :: tf
            real(wp),    intent(in)     :: ps
            real(wp),    intent(in)     :: pf
            real(wp),    intent(in)     :: elmbda
            real(wp),    intent(out)    :: pertrb
            real(wp),    intent(in)     :: bdts(:)
            real(wp),    intent(in)     :: bdtf(:)
            real(wp),    intent(in)     :: bdps(:)
            real(wp),    intent(in)     :: bdpf(:)
            real(wp),    intent(inout)  :: f(:,:)

        end subroutine hwsssp

        module subroutine hwscsp(intl, ts, tf, m, mbdcnd, bdts, bdtf, rs, rf, n, &
            nbdcnd, bdrs, bdrf, elmbda, f, idimf, pertrb, ierror, workspace)

            ! Dummy arguments
            integer(ip), intent(in)     :: intl
            integer(ip), intent(in)     :: m
            integer(ip), intent(in)     :: mbdcnd
            integer(ip), intent(in)     :: n
            integer(ip), intent(in)     :: nbdcnd
            integer(ip), intent(in)     :: idimf
            integer(ip), intent(out)    :: ierror
            real(wp),    intent(in)     :: ts
            real(wp),    intent(in)     :: tf
            real(wp),    intent(in)     :: rs
            real(wp),    intent(in)     :: rf
            real(wp),    intent(in)     :: elmbda
            real(wp),    intent(out)    :: pertrb
            real(wp),    intent(in)     :: bdts(:)
            real(wp),    intent(in)     :: bdtf(:)
            real(wp),    intent(in)     :: bdrs(:)
            real(wp),    intent(in)     :: bdrf(:)
            real(wp),    intent(inout)  :: f(:,:)
            class(FishpackWorkspace), intent(inout)  :: workspace
        end subroutine hwscsp
    end interface

end module centered_helmholtz_solvers


! 形状 (暂不服从开闭原则)，支持：点、线、圆、正方形、长方形、球、正方体、长方体。
module shape_m

    use, intrinsic :: iso_fortran_env, only: rk => real32, stdout => output_unit
    implicit none
    private

    public :: point_t, shape_t, cuboid_t, cube_t, square_t, rectangle_t, line_t, sphere_t, circle_t

    !> 点的坐标
    !> 支持1~3维
    type point_t
        real(rk), allocatable :: x(:) !! 坐标
        integer, allocatable :: id    !! 唯一标识
    end type point_t

    ! 形状类型
    type, abstract :: shape_t
    contains
        procedure(shape_t_contains), deferred :: contains       !! 查询点是否在形状内
        procedure(shape_t_intersects), deferred :: intersects   !! 查询是否相交
        procedure(shape_t_show), deferred :: show               !! 显示形状
    end type shape_t

    abstract interface
        logical pure function shape_t_contains(self, point)
            import shape_t, point_t
            class(shape_t), intent(in) :: self
            type(point_t), intent(in) :: point
        end function shape_t_contains
        logical pure function shape_t_intersects(self, other)
            import shape_t
            class(shape_t), intent(in) :: self
            class(shape_t), intent(in) :: other
        end function shape_t_intersects
        subroutine shape_t_show(self)
            import shape_t
            class(shape_t), intent(in) :: self
        end subroutine shape_t_show
    end interface

    type, extends(shape_t) :: line_t
        real(rk) :: center(1)
        real(rk) :: length
    contains
        procedure :: contains => line_t_contains
        procedure :: intersects => line_t_intersects
        procedure :: show => line_t_show
    end type line_t

    type, extends(shape_t) :: circle_t
        real(rk) :: center(2)
        real(rk) :: radius
    contains
        procedure :: contains => circle_t_contains
        procedure :: intersects => circle_t_intersects
        procedure :: show => circle_t_show
    end type circle_t

    type, extends(shape_t) :: square_t
        real(rk) :: center(2)
        real(rk) :: length
    contains
        procedure :: contains => square_t_contains
        procedure :: intersects => square_t_intersects
        procedure :: show => square_t_show
    end type square_t

    type, extends(shape_t) :: rectangle_t
        real(rk) :: center(2)
        real(rk) :: length(2)
    contains
        procedure :: contains => rectangle_t_contains
        procedure :: intersects => rectangle_t_intersects
        procedure :: show => rectangle_t_show
    end type rectangle_t

    type, extends(shape_t) :: sphere_t
        real(rk) :: center(3)
        real(rk) :: radius
    contains
        procedure :: contains => sphere_t_contains
        procedure :: intersects => sphere_t_intersects
        procedure :: show => sphere_t_show
    end type sphere_t

    type, extends(shape_t) :: cube_t
        real(rk) :: center(3)
        real(rk) :: length
    contains
        procedure :: contains => cube_t_contains
        procedure :: intersects => cube_t_intersects
        procedure :: show => cube_t_show
    end type cube_t

    type, extends(shape_t) :: cuboid_t
        real(rk) :: center(3)
        real(rk) :: length(3)
    contains
        procedure :: contains => cuboid_t_contains
        procedure :: intersects => cuboid_t_intersects
        procedure :: show => cuboid_t_show
    end type cuboid_t

contains

    !> func1 = x - y*0.5
    elemental real(rk) function func1(x, y)
        real(rk), intent(in) :: x, y
        func1 = x - y*0.5_rk
    end function func1

    !> func2 = x + y*0.5
    elemental real(rk) function func2(x, y)
        real(rk), intent(in) :: x, y
        func2 = x + y*0.5_rk
    end function func2

    logical pure function line_t_contains(self, point)
        class(line_t), intent(in) :: self
        type(point_t), intent(in) :: point
        line_t_contains = 2.0_rk*abs(self%center(1) - point%x(1)) < self%length
    end function line_t_contains

    logical pure function circle_t_contains(self, point)
        class(circle_t), intent(in) :: self
        type(point_t), intent(in) :: point
        associate (x => self%center, r => self%radius)
            circle_t_contains = hypot(point%x(1) - x(1), point%x(2) - x(2)) < r
        end associate
    end function circle_t_contains

    logical pure function square_t_contains(self, point)
        class(square_t), intent(in) :: self
        type(point_t), intent(in) :: point
        associate (x => self%center, l => self%length)
            square_t_contains = (point%x(1) > func1(x(1), l)) &
                                .and. (point%x(1) < func2(x(1), l)) &
                                .and. (point%x(2) > func1(x(2), l)) &
                                .and. (point%x(2) < func2(x(2), l))
        end associate
    end function square_t_contains

    logical pure function rectangle_t_contains(self, point)
        class(rectangle_t), intent(in) :: self
        type(point_t), intent(in) :: point
        associate (x => self%center, l => self%length)
            rectangle_t_contains = (point%x(1) > func1(x(1), l(1))) &
                                   .and. (point%x(1) < func2(x(1), l(1))) &
                                   .and. (point%x(2) > func1(x(2), l(2))) &
                                   .and. (point%x(2) < func2(x(2), l(2)))
        end associate
    end function rectangle_t_contains

    logical pure function sphere_t_contains(self, point)
        class(sphere_t), intent(in) :: self
        type(point_t), intent(in) :: point
        associate (x => self%center, r => self%radius)
            sphere_t_contains = norm2(point%x - x) < r
        end associate
    end function sphere_t_contains

    logical pure function cube_t_contains(self, point)
        class(cube_t), intent(in) :: self
        type(point_t), intent(in) :: point
        associate (x => self%center, l => self%length)
            cube_t_contains = (point%x(1) > func1(x(1), l)) &
                              .and. (point%x(1) < func2(x(1), l)) &
                              .and. (point%x(2) > func1(x(2), l)) &
                              .and. (point%x(2) < func2(x(2), l)) &
                              .and. (point%x(3) > func1(x(3), l)) &
                              .and. (point%x(3) < func2(x(3), l))
        end associate
    end function cube_t_contains

    logical pure function cuboid_t_contains(self, point)
        class(cuboid_t), intent(in) :: self
        type(point_t), intent(in) :: point
        associate (x => self%center, l => self%length)
            cuboid_t_contains = (point%x(1) > func1(x(1), l(1))) &
                                .and. (point%x(1) < func2(x(1), l(1))) &
                                .and. (point%x(2) > func1(x(2), l(2))) &
                                .and. (point%x(2) < func2(x(2), l(2))) &
                                .and. (point%x(3) > func1(x(3), l(3))) &
                                .and. (point%x(3) < func2(x(3), l(3)))
        end associate
    end function cuboid_t_contains

    logical pure function line_t_intersects(self, other)
        class(line_t), intent(in) :: self
        class(shape_t), intent(in) :: other
        select type (other)
        type is (line_t)
            associate (x => 2.0_rk*abs(self%center(1) - other%center(1)), &
                       l => self%length, &
                       l_ => other%length)
                line_t_intersects = x < (l + l_)
            end associate
        end select
    end function line_t_intersects

    logical pure function circle_t_intersects(self, other)
        class(circle_t), intent(in) :: self
        class(shape_t), intent(in) :: other
        select type (other)
        type is (square_t)
            associate (x => abs(other%center - self%center), r => self%radius, l => other%length)
            if (any(x >= func2(r, l))) then
                circle_t_intersects = .false.
                return
            end if
            if (all(x < l*0.5)) then
                circle_t_intersects = .true.
                return
            end if
            circle_t_intersects = norm2(func1(x, l)) < r
            end associate
        type is (rectangle_t)
            associate (x => abs(other%center - self%center), r => self%radius, l => other%length)
            if (any(x >= func2(r, l))) then
                circle_t_intersects = .false.
                return
            end if
            if (all(x < l*0.5)) then
                circle_t_intersects = .true.
                return
            end if
            circle_t_intersects = norm2(func1(x, l)) < r
            end associate
        end select
    end function circle_t_intersects

    logical pure function square_t_intersects(self, other)
        class(square_t), intent(in) :: self
        class(shape_t), intent(in) :: other
        select type (other)
        type is (square_t)
            associate (lb => func1(self%center, self%length), &
                       rt => func2(self%center, self%length), &
                       lb_ => func1(other%center, other%length), &
                       rt_ => func2(other%center, other%length))
                square_t_intersects = any(lb < rt_) .or. any(rt > lb_)
            end associate
        type is (rectangle_t)
            associate (lb => func1(self%center, self%length), &
                       rt => func2(self%center, self%length), &
                       lb_ => func1(other%center, other%length), &
                       rt_ => func2(other%center, other%length))
                square_t_intersects = any(lb < rt_) .or. any(rt > lb_)
            end associate
        end select
    end function square_t_intersects

    logical pure function rectangle_t_intersects(self, other)
        class(rectangle_t), intent(in) :: self
        class(shape_t), intent(in) :: other
        select type (other)
        type is (square_t)
            associate (lb => func1(self%center, self%length), &
                       rt => func2(self%center, self%length), &
                       lb_ => func1(other%center, other%length), &
                       rt_ => func2(other%center, other%length))
                rectangle_t_intersects = any(lb < rt_) .or. any(rt > lb_)
            end associate
        type is (rectangle_t)
            associate (lb => func1(self%center, self%length), &
                       rt => func2(self%center, self%length), &
                       lb_ => func1(other%center, other%length), &
                       rt_ => func2(other%center, other%length))
                rectangle_t_intersects = any(lb < rt_) .or. any(rt > lb_)
            end associate
        end select
    end function rectangle_t_intersects

    logical pure function sphere_t_intersects(self, other)
        class(sphere_t), intent(in) :: self
        class(shape_t), intent(in) :: other
        select type (other)
        type is (cube_t)
            associate (x => abs(other%center - self%center), r => self%radius, l => other%length)
            if (any(x >= func2(r, l))) then
                sphere_t_intersects = .false.
                return
            end if
            if (all(x < l*0.5)) then
                sphere_t_intersects = .true.
                return
            end if
            sphere_t_intersects = norm2(func1(x, l)) < r
            end associate
        type is (cuboid_t)
            associate (x => abs(other%center - self%center), r => self%radius, l => other%length)
            if (any(x >= func2(r, l))) then
                sphere_t_intersects = .false.
                return
            end if
            if (all(x < l*0.5)) then
                sphere_t_intersects = .true.
                return
            end if
            sphere_t_intersects = norm2(func1(x, l)) < r
            end associate
        end select
    end function sphere_t_intersects

    logical pure function cube_t_intersects(self, other)
        class(cube_t), intent(in) :: self
        class(shape_t), intent(in) :: other
        select type (other)
        type is (cuboid_t)
            associate (lbb => func1(self%center, self%length), &
                       rtf => func2(self%center, self%length), &
                       lbb_ => func1(other%center, other%length), &
                       rtf_ => func2(other%center, other%length))
                cube_t_intersects = any(lbb < rtf_) .or. any(rtf > lbb_)
            end associate
        type is (cube_t)
            associate (lbb => func1(self%center, self%length), &
                       rtf => func2(self%center, self%length), &
                       lbb_ => func1(other%center, other%length), &
                       rtf_ => func2(other%center, other%length))
                cube_t_intersects = any(lbb < rtf_) .or. any(rtf > lbb_)
            end associate
        end select
    end function cube_t_intersects

    logical pure function cuboid_t_intersects(self, other)
        class(cuboid_t), intent(in) :: self
        class(shape_t), intent(in) :: other
        select type (other)
        type is (cuboid_t)
            associate (lbb => func1(self%center, self%length), &
                       rtf => func2(self%center, self%length), &
                       lbb_ => func1(other%center, other%length), &
                       rtf_ => func2(other%center, other%length))
                cuboid_t_intersects = any(lbb < rtf_) .or. any(rtf > lbb_)
            end associate
        type is (cube_t)
            associate (lbb => func1(self%center, self%length), &
                       rtf => func2(self%center, self%length), &
                       lbb_ => func1(other%center, other%length), &
                       rtf_ => func2(other%center, other%length))
                cuboid_t_intersects = any(lbb < rtf_) .or. any(rtf > lbb_)
            end associate
        end select
    end function cuboid_t_intersects

    subroutine line_t_show(self)
        class(line_t), intent(in) :: self
        write (stdout, '(2(a,es10.3))') "line_t: center = [", self%center, " ], length = ", self%length
    end subroutine line_t_show

    subroutine circle_t_show(self)
        class(circle_t), intent(in) :: self
        write (stdout, '(a,2(es10.3,1x),a,es10.3)') "circle_t: center = [", self%center, &
            " ], radius = ", self%radius
    end subroutine circle_t_show

    subroutine square_t_show(self)
        class(square_t), intent(in) :: self
        write (stdout, '(a,2(es10.3,1x),a,es10.3)') "square_t: center = [", self%center, &
            " ], length = ", self%length
    end subroutine square_t_show

    subroutine rectangle_t_show(self)
        class(rectangle_t), intent(in) :: self
        write (stdout, '(2(a,2(es10.3,1x)))') "rectangle_t: center = [", self%center, &
            " ], length = ", self%length
    end subroutine rectangle_t_show

    subroutine sphere_t_show(self)
        class(sphere_t), intent(in) :: self
        write (stdout, '(a,3(es10.3,1x),a,es10.3)') "sphere_t: center = [", self%center, &
            " ], radius = ", self%radius
    end subroutine sphere_t_show

    subroutine cube_t_show(self)
        class(cube_t), intent(in) :: self
        write (stdout, '(a,3(es10.3,1x),a,es10.3)') "cube_t: center = [", self%center, &
            " ], length = ", self%length
    end subroutine cube_t_show

    subroutine cuboid_t_show(self)
        class(cuboid_t), intent(in) :: self
        write (stdout, '(2(a,3(es10.3,1x)))') "cuboid_t: center = [", self%center, &
            " ], length = ", self%length
    end subroutine cuboid_t_show

end module shape_m


SUBROUTINE sparin_gauss(kv,kdiag)
!
! This subroutine performs Gaussian factorisation of a skyline matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::kdiag(:)
 REAL(iwp),INTENT(OUT)::kv(:)
 REAL(iwp)::num,den,fac,zero=0.0_iwp
 INTEGER::n,ii,i,j,k,l,kk,l1,l2,l3
 n=UBOUND(kdiag,1)
 DO j=1,n-1
   den=kv(kdiag(j))
   ii=0
   DO i=j+1,n
     ii=ii+1
     l=kdiag(i)-ii
     IF(l-kdiag(i-1)>zero)THEN
       num=kv(l)
       fac=num/den
       kk=-1
       DO k=i,n
         kk=kk+1
         l1=kdiag(i+kk)-kk
         l2=l1-ii
         l3=kdiag(i+kk-1)
         IF(l2-l3>zero)kv(l1)=kv(l1)-fac*kv(l2)
       END DO
     END IF
   END DO
 END DO
RETURN
END SUBROUTINE sparin_gauss


! *****************************COPYRIGHT*******************************
! (C) Crown copyright Met Office. All rights reserved.
! For further details please refer to the file COPYRIGHT.txt
! which you should have received as part of this distribution.
! *****************************COPYRIGHT*******************************
!
! This file is part of the UM Shared Library project.
!
! The UM Shared Library is free software: you can redistribute it
! and/or modify it under the terms of the Modified BSD License, as
! published by the Open Source Initiative.
!
! The UM Shared Library is distributed in the hope that it will be
! useful, but WITHOUT ANY WARRANTY; without even the implied warranty
! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! Modified BSD License for more details.
!
! You should have received a copy of the Modified BSD License
! along with the UM Shared Library.
! If not, see <http://opensource.org/licenses/BSD-3-Clause>.
!
!*******************************************************************************
!
! Description : A module containing constants/parameters for Chemistry
!
MODULE f_shum_chemistry_constants_mod

USE, INTRINSIC :: ISO_C_BINDING, ONLY:                                         &
  C_DOUBLE

IMPLICIT NONE

PRIVATE

PUBLIC :: shum_avogadro_const,        shum_boltzmann_const,                   &
          shum_rho_so4_const,         shum_ref_mfp_const,                     &
          shum_tref_mfp_const,        shum_pref_mfp_const

!------------------------------------------------------------------------------!
! We're going to use the types from the ISO_C_BINDING module, since although   !
! the REALs aren't 100% guaranteed to correspond to the sizes we want to       !
! enforce, they should be good enough on the majority of systems.              !
!                                                                              !
! Additional protection for the case that FLOAT/DOUBLE do not conform to the   !
! sizes we expect is provided via the "precision_bomb" macro-file              !
!------------------------------------------------------------------------------!
INTEGER, PARAMETER :: real64 = C_DOUBLE
!------------------------------------------------------------------------------!

! No. of molecules in 1 mole
REAL(KIND=real64), PARAMETER :: shum_avogadro_const = 6.022e23_real64

! Boltzmanns constant (J K-1)
REAL(KIND=real64), PARAMETER :: shum_boltzmann_const = 1.3804e-23_real64

! Density of SO4 particle (kg/m3)
REAL(KIND=real64), PARAMETER :: shum_rho_so4_const = 1769.0_real64

! Mean Free Path
! Ref value (m)
REAL(KIND=real64), PARAMETER :: shum_ref_mfp_const  = 6.6e-8_real64
! Ref temperature (K)
REAL(KIND=real64), PARAMETER :: shum_tref_mfp_const = 293.15_real64
! Ref pressure (Pa)
REAL(KIND=real64), PARAMETER :: shum_pref_mfp_const = 1.01325e5_real64

END MODULE f_shum_chemistry_constants_mod


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of PACK (valid cases)
module m
  integer, parameter :: arr(2,3) = reshape([1, 2, 3, 4, 5, 6], shape(arr))
  logical, parameter :: odds(*,*) = modulo(arr, 2) /= 0
  integer, parameter :: vect(*) = [(j, j=-10, -1)]
  logical, parameter :: test_pack_1 = all(pack(arr, .true.) == [arr])
  logical, parameter :: test_pack_2 = all(pack(arr, .false.) == [integer::])
  logical, parameter :: test_pack_3 = all(pack(arr, odds) == [1, 3, 5])
  logical, parameter :: test_pack_4 = all(pack(arr, .not. odds) == [2, 4, 6])
  logical, parameter :: test_pack_5 = all(pack(arr, .true., vect) == [1, 2, 3, 4, 5, 6, -4, -3, -2, -1])
  logical, parameter :: test_pack_6 = all(pack(arr, .false., vect) == vect)
  logical, parameter :: test_pack_7 = all(pack(arr, odds, vect) == [1, 3, 5, -7, -6, -5, -4, -3, -2, -1])
  logical, parameter :: test_pack_8 = all(pack(arr, .not. odds, vect) == [2, 4, 6, -7, -6, -5, -4, -3, -2, -1])
end module


! =====================================================================
! subroutine LHSP
!
! This subroutine constructs the left-hand side matrix for the
! Peaceman-Rachford step involving the angular kinetic energy
! terms. It has been modified for imaginary time propagation.
! ---------------------------------------------------------------------
      subroutine LHSP(nP,dT,TPD,TPO,VS,DL,D,DU)
      implicit none

      integer :: nP
      double precision :: dT
      double precision :: TPD
      double precision :: TPO
      double precision :: VS(nP)
      double complex :: DL(nP-1)
      double complex :: D(nP)
      double complex :: DU(nP-1)

      integer :: i

      DL(1) = dcmplx(-0.5d0*dT*TPO,0.0d0)
      D(1) = dcmplx(1.0d0+0.5d0*dT*TPD+0.25d0*dT*VS(1)+0.5d0*dT*TPO,0.0d0)
      DU(1) = dcmplx(-0.5d0*dT*TPO,0.0d0)
      do i = 2, nP-1
         DL(i) = dcmplx(-0.5d0*dT*TPO,0.0d0)
         D(i) = dcmplx(1.0d0+0.5d0*dT*TPD+0.25d0*dT*VS(i),0.0d0)
         DU(i) = dcmplx(-0.5d0*dT*TPO,0.0d0)
      enddo
      D(nP) = dcmplx(1.0d0+0.5d0*dT*TPD+0.25d0*dT*VS(nP)+0.5d0*dT*TPO,0.0d0)

      return
      end
! =====================================================================


      FUNCTION POIDEV(XM,IDUM)
      PARAMETER (PI=3.141592654)
      DATA OLDM /-1./
      IF (XM.LT.12.)THEN
        IF (XM.NE.OLDM) THEN
          OLDM=XM
          G=EXP(-XM)
        ENDIF
        EM=-1
        T=1.
2       EM=EM+1.
        T=T*RAN1(IDUM)
        IF (T.GT.G) GO TO 2
      ELSE
        IF (XM.NE.OLDM) THEN
          OLDM=XM
          SQ=SQRT(2.*XM)
          ALXM=ALOG(XM)
          G=XM*ALXM-GAMMLN(XM+1.)
        ENDIF
1       Y=TAN(PI*RAN1(IDUM))
        EM=SQ*Y+XM
        IF (EM.LT.0.) GO TO 1
        EM=INT(EM)
        T=0.9*(1.+Y**2)*EXP(EM*ALXM-GAMMLN(EM+1.)-G)
        IF (RAN1(IDUM).GT.T) GO TO 1
      ENDIF
      POIDEV=EM
      RETURN
      END


!*****************************************************************************
! FILE: omp_dotprod_serial.f
! DESCRIPTION:
!   This simple program is the serial version of a dot product and the
!   first of four codes used to show the progression from a serial program to a
!   hybrid MPI/OpenMP program.  The relevant codes are:
!      - omp_dotprod_serial.f  - Serial version
!      - omp_dotprod_openmp.f  - OpenMP only version
!      - omp_dotprod_mpi.f     - MPI only version
!      - omp_dotprod_hybrid.f  - Hybrid MPI and OpenMP version
! SOURCE: Blaise Barney
! LAST REVISED:  06/02/17 Blaise Barney
!******************************************************************************

      program dotprod

! Define length of dot product vectors
      integer VECLEN
      parameter(VECLEN=100)

      integer i
      real*8 a(VECLEN), b(VECLEN), sum

      print *, 'Starting omp_dotprod_serial'

! Initialize dot product vectors
      do i=1, VECLEN
        a(i)=1.0
        b(i)=a(i)
      end do

! Perform the dot product
      sum = 0.0
      do i=1, VECLEN
        sum = sum + a(i) * b(i)
      end do

      print *, 'Done. Serial version: sum  =', sum

      end


C
C	$Id: csarclen.f,v 1.6 2008-07-27 03:10:05 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION CSARCLEN (P,Q)
      DOUBLE PRECISION P(3), Q(3)
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   05/09/92
C
C   This function computes the arc-length (angle in radians)
C between a pair of points on the unit sphere.
C
C On input:
C
C       P,Q = Arrays of length 3 containing the X, Y, and Z
C             coordinates (in that order) of points on the
C             unit sphere.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       CSARCLEN = Angle in radians between the unit vectors
C                P and Q.  0 .LE. CSARCLEN .LE. PI.
C
C Modules required by CSARCLEN:  None
C
C Intrinsic functions called by CSARCLEN:  ATAN, SQRT
C
C***********************************************************
C
      INTEGER I
      DOUBLE PRECISION D
C
C Local parameters:
C
C D = Euclidean norm squared of P+Q
C I = DO-loop index
C
      D = 0.
      DO 1 I = 1,3
        D = D + (P(I) + Q(I))**2
    1   CONTINUE
      IF (D .EQ. 0.) THEN
C
C P and Q are separated by 180 degrees.
C
        CSARCLEN = 4.D0*ATAN(1.D0)
      ELSEIF (D .GE. 4.D0) THEN
C
C P and Q coincide.
C
        CSARCLEN = 0.
      ELSE
        CSARCLEN = 2.D0*ATAN(SQRT((4.D0-D)/D))
      ENDIF
      RETURN
      END


module calc_kine_temp_module

  implicit none

  private
  public :: calc_Ndof, get_Ndof
  public :: calc_kine
  public :: calc_temp

  real(8),parameter :: TOJOUL=4.35975d-18 ! (J/hartree)
  real(8),parameter :: kB_J=1.380658d-23  ! (J/K)
  real(8),parameter :: kB=kB_J/TOJOUL     ! (hartree/K)

  integer :: N_degree_of_freedom=0

contains

  subroutine calc_Ndof ! Degree of freedom
    use atom_module, only: md_atom
    use force_module, only: tim
    implicit none
    real(8) :: v(3),u(3)
    integer :: i,m,natom,Ndof
    call random_number( v )
    natom=size(md_atom)
    Ndof=0
    do i=1,natom
      m=md_atom(i)
      u(:) = matmul( tim(:,:,m), v(:) )
      Ndof = Ndof + count( u /= 0.0d0 )
    end do
    Ndof = Ndof - 3  ! Subtract center-of-mass dof
    if ( Ndof <= 0 ) Ndof=Ndof+3
    N_degree_of_freedom=Ndof
  end subroutine calc_Ndof

  subroutine get_Ndof( Ndof_out )
    implicit none
    integer,intent(out) :: Ndof_out
    if ( N_degree_of_freedom == 0 ) call calc_Ndof
    Ndof_out = N_degree_of_freedom
  end subroutine get_Ndof

  subroutine calc_kine( Velocity, kine, temp )
    use atom_module, only: zn_atom, ki_atom
    use cpmd_variables, only: pmass, AMU
    implicit none
    real(8),intent(in)  :: Velocity(:,:)
    real(8),intent(out) :: kine
    real(8),optional,intent(out) :: temp
    integer :: i,natom,Ndof
    real(8) :: pm
    natom=size(Velocity,2)
    kine=0.0d0
    do i=1,natom
      pm = pmass( zn_atom(ki_atom(i)) )
      kine = kine + sum( Velocity(:,i)**2 )*pm
    end do
    kine=kine*0.5d0*AMU
    if ( present(temp) ) then
      call get_Ndof( Ndof )
      temp=kine/( 0.5d0*Ndof*kB )
    end if
  end subroutine calc_kine

  subroutine calc_temp( Velocity, temp )
    implicit none
    real(8),intent(in)  :: Velocity(:,:)
    real(8),intent(out) :: temp
    real(8) :: kine
    integer :: Ndof
    call calc_kine( Velocity, kine )
    call get_Ndof( Ndof )
    temp = kine/( 0.5d0*Ndof*kB )
  end subroutine calc_temp

end module calc_kine_temp_module


!# cut_sphere           D. Hollas, 2014
!- Program for cutting solvent molecules around the solute
!  from an xyz file.

!- It assumes that the solute atoms are the first atoms in the file.
!- The coordinates are read from standard input.
!- See help in subroutine PrintHelp().

!  There are two modes of action:
!  i) Pick closest nmol solvent molecules.
!  ii) Pick all solvent molecules within specified radius.

!- There are 3 ways how to determine the distance of solvent to solute.
!  1. Closest distance between ANY solvent atom and ANY solute atom.
!     This is the default if we want specific number of solvent molecules.
!  2. Distance is determined relative to the geometrical center of the solute.
!     This is the default if we cut specific radius. (option -com)
!  3. Distance is determined relative to one specific atom of the solute.
!     (option -i idx)

program cut_sphere
   implicit none
   integer, parameter :: MAXATOM=10000
   character(len=2)   :: at(maxatom),at_temp(MAXATOM)
   real*8    :: x(maxatom), y(maxatom), z(maxatom)
   real*8    :: x_temp(maxatom), y_temp(maxatom), z_temp(maxatom)
   real*8    :: rmin(maxatom),r(maxatom,maxatom), rmolmin(maxatom)
   integer   :: index(maxatom),index_rev(maxatom)
   integer   :: natmol=3, nmol=-1, nsolute=-1, atidx=-1
   integer   :: nmoltotal, natom
   real*8    :: rad=-1
   logical   :: lcom=.false., ltrans=.false., lref=.false.
   integer   :: i, j, iat, imol, idx
   real*8    :: xt, yt, zt, get_distance, box(3)
   character(len=100) :: chjunk, chref

   box(1)=-1; box(2)=-1; box(3)=-1;

   call Get_cmdline(natmol, nmol, nsolute, rad, lcom, atidx, ltrans, lref, chref, box)

   read(*,*)natom
   if(natom.gt.maxatom)then
      write(*,*)'ERROR: number of atoms is greater than maximum.'
      write(*,*)'Adjust parameter MAXATOM and recompile'
      stop 1
   end if

   read(*,*)
   do i=1,natom
      read(*,*)at(i),x(i),y(i),z(i)
   enddo

   ! When using reference geometry (e.g. if we are "cutting" velocities)
   if(lref)then
      at_temp=at
      x_temp=x
      y_temp=y
      z_temp=z
      open(500, file=chref,access="sequential",action="read")
      read(500,*)i
      if(i.ne.natom)then
         write(*,*)"ERROR: Number of atoms in reference and input files do not match!"
         stop 1
      end if

      read(500,*)
      do i=1,natom
         read(500,*)at(i),x(i),y(i),z(i)
         if(at(i).ne.at_temp(i))then
            write(*,*)"ERROR: Incompatible atom types!",at(i),at_temp(i),"Line:",i
            stop 1
         end if
      enddo

   end if

   if (lcom.or.ltrans)then
      xt=0.0
      yt=0.0
      zt=0.0
      do i=1,nsolute
         xt=xt+x(i)
         yt=yt+y(i)
         zt=zt+z(i)
      enddo
      xt=xt/nsolute
      yt=yt/nsolute
      zt=zt/nsolute
      write(*,*)'Coordinates of the geometrical center of the solute.'
      write(*,*)xt, yt, zt
   end if

   if(atidx.gt.0)then
      xt=x(atidx)
      yt=y(atidx)
      zt=z(atidx)
      write(*,*)'Coordinates of the atom around which we cut:'
      write(*,*)xt, yt, zt
   end if

   if (ltrans.or.box(1).gt.0)then
      write(*,*)'Origin of coordinates will be a:'
      write(*,*)xt, yt, zt
      write(*,*)'Translating the molecule to the origin.'
      do iat=1,natom
         x(iat)=x(iat)-xt
         y(iat)=y(iat)-yt
         z(iat)=z(iat)-zt
      end do
      xt=0.0d0; yt=0.0d0; zt=0.0d0
   end if

!  Determine the closest distance of every solvent atoms to solute
!  based on all atoms in the solute
   if(.not.lcom.and.atidx.lt.0)then
      do i=nsolute+1,natom
         rmin(i)=100000d0
         do j=1,nsolute
            r(i,j) = get_distance(x(j), y(j), z(j), x(i), y(i), z(i), box)
!            r(i,j)=(x(i)-x(j))**2+(y(i)-y(j))**2+(z(i)-z(j))**2
!            r(i,j)=dsqrt(r(i,j))
            if(r(i,j).lt.rmin(i))then
               rmin(i)=r(i,j)
            endif
         enddo
      enddo
   end if

!  Determine the distances to the geometrical center
!  or to an atom with index atidx
   if(lcom.or.atidx.gt.0)then
      do i=nsolute+1,natom
         rmin(i) = get_distance(xt, yt, zt, x(i), y(i), z(i), box)
      enddo
   end if

!  total number of solvent molecules
   nmoltotal=(natom-nsolute)/natmol

!  Now we have to determine, which atom in each molecule is closest
!  i.e. determine the distance of each solvent molecule from solute
   do imol=1,nmoltotal
      rmolmin(imol)=10000d0
      idx=nsolute+1+(imol-1)*natmol
      do iat=idx,idx+natmol-1
         if(rmin(iat).lt.rmolmin(imol))then
            rmolmin(imol)=rmin(iat)
         endif
      enddo
   enddo

! determine, how many molecules are in the radius
   if (rad.gt.0)then
      nmol=0
      do imol=1,nmoltotal
         if(rmolmin(imol).lt.rad)then
            nmol=nmol+1
         end if
      end do
      write(*,*)'Number of solvent molecules within radius ',rad
      write(*,*)'is', nmol
   end if

! Center the solvent molecules around solute if PBC
  if(box(1).gt.0) call solvent2box(x, y, z, box, nsolute, nmoltotal, natmol, MAXATOM)

! Here's where the index ordering happens.
! ###############################################
   do i=1,nmoltotal
      index(i)=1
      do j=1,nmoltotal

         if(i.eq.j) cycle

!        now we have to determine, which molecule is closer
         if(rmolmin(i).gt.rmolmin(j))then
          index(i)=index(i)+1
         endif

      enddo
      index_rev(index(i))=i
   enddo

!  Move input coordinates back in place
!  instead of reference geometry
   if(lref)then
      x=x_temp
      y=y_temp
      z=z_temp
   end if

!  WRITE THE RESULTS----------------------
   open(150,file='cut_qm.xyz')
   write(150,*)natmol*nmol+nsolute
   write(150,*)
   ! first write solute
   do idx=1,nsolute
      write(150,*)at(idx),x(idx),y(idx),z(idx)
   end do
   ! now write ordered solvent molecules
   do imol=1,nmol
      do iat=1,natmol
         idx=nsolute+(index_rev(imol)-1)*natmol+iat
         write(150,*)at(idx),x(idx),y(idx),z(idx)
      enddo
   enddo

   close(150)

!  Now print the solvent that we left out.
   open(150,file='cut_mm.xyz')
   write(150,*)natom-natmol*nmol-nsolute
   write(150,*)
   do imol=nmol+1,nmoltotal
      do iat=1,natmol
         idx=nsolute+(index_rev(imol)-1)*natmol+iat
         write(150,*)at(idx),x(idx),y(idx),z(idx)
      enddo
   enddo

   close(150)

end

subroutine Get_cmdline(natmol, nmol, nsolute, rad, lcom, atidx, ltrans, lref, chref, box)
implicit none
real*8,intent(inout)    :: rad, box(3)
integer, intent(inout)  :: natmol, nmol, nsolute, atidx
logical, intent(inout)  :: lcom, ltrans, lref
character(len=*), intent(out) :: chref
character(len=100)      :: arg
integer                 :: i
real*8                  :: distmax

i=0
do while (i < command_argument_count())
  i=i+1
  call get_command_argument(i, arg)

  select case (arg)
  case ('-h', '--help')
    call PrintHelp()
    stop
  case ('-u')
    i=i+1
    call get_command_argument(i, arg)
    read(arg,*)nsolute
  case ('-v')
    i=i+1
    call get_command_argument(i, arg)
    read(arg,*)nmol
    if (nmol.le.0)then
       call PrintHelp()
       write(*,*)'ERROR: Number of molecules must be a positive integer.'
       call PrintInputError()
    endif
  case ('-va')
    i=i+1
    call get_command_argument(i, arg)
    read(arg,*)natmol
  case ('-r')
    i=i+1
    call get_command_argument(i, arg)
    read(arg,*)rad
    if (rad.le.0)then
       call PrintHelp()
       write(*,*)'ERROR: Radius must be positive.'
       call PrintInputError()
    endif
  case ('-i')
    i=i+1
    call get_command_argument(i, arg)
    read(arg,*)atidx
    if (atidx.le.0)then
       call PrintHelp()
       write(*,*)'ERROR: Atom index must be positive.'
       call PrintInputError()
    endif
  case ('-com')
    lcom=.true.
  case ('-ref')
    lref=.true.
    i=i+1
    call get_command_argument(i, arg)
    read(arg,'(A)')chref
    write(*,*)'Using reference file '//trim(chref)
  case ('-trans')
    ltrans=.true.
  case ('-box')
    i=i+1
    call get_command_argument(i, arg)
    read(arg,*)box(1)
    i=i+1
    call get_command_argument(i, arg)
    read(arg,*)box(2)
    i=i+1
    call get_command_argument(i, arg)
    read(arg,*)box(3)
  case default
    call PrintHelp()
    write(*,*)'Invalid command line argument!'
    call PrintInputError()
  end select

end do

! INPUT SANITY CHECK
  if(rad.gt.0.and.nmol.gt.0)then
     write(*,*)'ERROR: Conflicting options -v and -r.'
     write(*,*)'You may cut EITHER constant number of solvent molecules,'
     write(*,*)'OR cut sphere of solvent of fixed radius.'
     call PrintHelp()
     call PrintInputError()
  end if

  if(nmol.lt.0.and.rad.lt.0)then
     call PrintHelp()
     write(*,*)'ERROR: Missing option -v or -r.'
     call PrintInputError()
  end if

  if(nsolute.lt.0)then
     call PrintHelp()
     write(*,*)'ERROR: Number of atoms in solute not specified.'
     call PrintInputError()
  end if

  if(natmol.lt.0)then
     call PrintHelp()
     write(*,*)'ERROR: Number of atoms in a solvent molecule must be positive.'
     call PrintInputError()
  end if

  if(rad.gt.0.and.atidx.le.0)then
     lcom=.true.
  end if

  ! Check size of the box
  if(box(1).gt.0)then
     distmax=100000
     do i=1,3
        if(box(i).lt.distmax) distmax = box(i)
     end do
     distmax = distmax / 2.0d0

     if(.not.lcom.and.atidx.le.0)then
        write(*,*)'ERROR: PBC not supported with this setting.'
        write(*,*)'Please set -com or -i options.'
        stop 1
     end if
  end if

  if(rad.gt.0.and.box(1).gt.0)then
     if(rad.gt.distmax)then
        write(*,*)'Error: Radius is bigger that half size of the box!'
     end if
  end if

end subroutine Get_cmdline

real*8 function get_distance(x1, y1, z1, x2, y2, z2, box)
   implicit none
   real*8,intent(in)  :: x1, y1, z1
   real*8,intent(inout)  :: x2, y2, z2
   real*8,intent(in)  :: box(3)
!   real*8,optional,intent(in)  :: box(3)
   real*8  :: dx, dy, dz, temp

   dx = x1 - x2
   dy = y1 - y2
   dz = z1 - z2

!   if (present(box))then
     if (box(1).gt.0)then
        dx = dx - box(1) * nint(dx/box(1))
        dy = dy - box(2) * nint(dy/box(2))
        dz = dz - box(3) * nint(dz/box(3))
      end if
!   end if

   temp = dx*dx + dy*dy + dz*dz
   temp = dsqrt(temp)
   get_distance = temp
   return

end function

! WARNING: this code works only if -com or -i are set
! We expect that the molecules have been translated to the center of origin
subroutine solvent2box(x, y, z, box, nsolute, nmoltotal, natmol,maxatom)
implicit none
real*8,intent(inout) :: x(maxatom), y(maxatom), z(maxatom)
real*8,intent(in)    :: box(3)
integer,intent(in)   :: nsolute, nmoltotal, natmol, maxatom
real*8   :: dx, dy, dz, temp
integer  :: imol, iat, idx
real*8   :: shiftx, shifty, shiftz, pom
real*8, parameter    :: epsilon=0.000001d0

do imol=1, nmoltotal

   shiftx=0.0d0 ; shifty=0.0d0 ; shiftz=0.0d0
!  First determine, whether we shift in given direction
   do iat=1,natmol
      idx = nsolute + (imol-1)*natmol+iat
      pom = nint(x(idx)/box(1)) * box(1)
      if(abs(pom).gt.abs(shiftx)) shiftx = pom
      pom = nint(y(idx)/box(2)) * box(2)
      if(abs(pom).gt.abs(shifty)) shifty = pom
      pom = nint(z(idx)/box(3)) * box(3)
      if(abs(pom).gt.abs(shiftz)) shiftz = pom
   end do

!  Shift solvent molecules as a whole!!
   if(abs(shiftx).gt.epsilon)then
     do iat=1,natmol
         idx = nsolute + (imol-1)*natmol+iat
         x(idx) = x(idx) - shiftx
     end do
   end if
   if(abs(shifty).gt.epsilon)then
     do iat=1,natmol
         idx = nsolute + (imol-1)*natmol+iat
         y(idx) = y(idx) - shifty
     end do
   end if
   if(abs(shiftz).gt.epsilon)then
     do iat=1,natmol
         idx = nsolute + (imol-1)*natmol+iat
         z(idx) = z(idx) - shiftz
     end do
   end if

end do

end subroutine

subroutine PrintHelp()
implicit none
    print '(a)', ''
    print '(a)', 'Program for cutting solvent molecules around a given solute from a larger solvated system.'
    print '(a)', 'You may cut either specific number of closest solvent molecules'
    print '(a)', 'or all solvent mocules within given radius.'
    print '(a)', ''
    print '(a)', 'There are 3 ways how to determine the distance of solvent to solute.'
    print '(a)', '  1. Closest distance between ANY solvent atom and ANY solute atom.'
    print '(a)', '     This is the default if you want specific number of solvent molecules.'
    print '(a)', '  2. Distance is determined relative to the geometrical center of the solute.'
    print '(a)', '     This is the default if you cut specific radius. (option -com)'
    print '(a)', '  3. Distance is determined relative to one specific atom of the solute.'
    print '(a)', '     (option -i idx)'
    print '(a)', ''
    print '(a)', 'USAGE: ./cut_sphere [OPTIONS] < input.xyz'
    print '(a)', ''
    print '(a)', 'The output geometries are written to files cut_qm.xyz and cut_mm.xyz.'
    print '(a)', ''
    print '(a)', 'cmdline options:'
    print '(a)', ''
    print '(a)', '  -h or --help     Print this information and exit.'
    print '(a)', '  -u  <integer>    Number of atoms in the solute.'
    print '(a)', '  -va <integer>    Number of atoms in one solvent molecule (default=3).'
    print '(a)', '  -v  <integer>    Number solvent molecules to cut.'
    print '(a)', '  -r  <radius>     Radius of the sphere to cut.'
    print '(a)', '  -i  <atidx>      Cut around the atom with index atidx.'
    print '(a)', '  -com             Cut around the geometrical center of molecule.'
    print '(a)', '                   This is the default if -r is specified.'
    print '(a)', '  -trans           Translate the molecule so that the &
                  coordinates of geometrical center are (0, 0, 0).'
    print '(a)', '  -ref <file_name> Use reference geometry to determine atomic distances.'
    print '(a)', '                   Useful when you need to "cut" velocities.'
    print '(a)', '  -box <size_x size_y size_z>  Dimensions of periodic boundary box.'
end subroutine PrintHelp

subroutine PrintInputError()
  write(*,*)'Error during reading input. Exiting...'
  stop 1
end subroutine PrintInputError


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

!* Tests for runtime library MATMUL routines

program p

  parameter(NbrTests=208)

  integer*4, dimension(4,3) :: arr1
  integer*4, dimension(3) :: arr2
  integer*4, dimension(4) :: arr3
  integer*4, dimension(4,4) :: arr4
  integer*4, dimension(0:3,-1:1) :: arr5
  integer*4, dimension(-3:-1) :: arr6
  integer*4, dimension(-1:2,0:3) :: arr7
  integer*4, dimension(2:5,3) :: arr8
  integer*4, dimension(2:4) :: arr9
  integer*4, dimension(2:5) :: arr10
  integer*4, dimension(4,2:4) :: arr11
  integer*4, dimension(2:5) :: arr12

  data arr1 /0,1,2,3,4,5,6,7,8,9,10,11/
  data arr5 /0,1,2,3,4,5,6,7,8,9,10,11/
  data arr2 /0,1,2/
  data arr6 /0,1,2/
  data arr3 /0,1,2,3/
  data arr4 /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/
  data arr7 /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/
  data arr8 /0,1,2,3,4,5,6,7,8,9,10,11/
  data arr9 /0,1,2/
  data arr10 /0,1,2,3/
  data arr11 /0,1,2,3,4,5,6,7,8,9,10,11/

  integer*4 :: expect(NbrTests)
  integer*4 :: results(NbrTests)

  data expect /  &
  ! tests 1-4
      20, 23, 26, 29,  &
  ! tests 5-8
      0, 23, 26, 29,  &
  ! tests 9-12
      23, 26, 29, 0,  &
  ! tests 13-16
      0, 20, 23, 26,  &
  ! tests 17-20
      0, 5, 6, 7,  &
  ! tests 21-24
      8, 9, 10, 11,  &
  ! tests 25-28
      8, 11, 14, 17,  &
  ! tests 29-32
      0, 8, 11, 14,  &
  ! tests 33-36
      9, 10, 11, 0,  &
  ! tests 37-40
      18, 20, 22, 0,  &
  ! tests 41-44
      0, 8, 0, 14,  &
  ! tests 45-48
      9, 0, 11,  &
      0,  &
  ! tests 49-64
      0, 9, 0, 0, 0, 0, 0, 0, 0, 11, 0, 0,  &
      0, 0, 0, 0,  &
  ! tests 65-80
      0, 0, 0, 0, 0, 0, 0, 0, 9, 0, 11, 0,  &
      0, 0, 0, 0,  &
  ! tests 81-96
      0, 9, 0, 0, 0, 0, 0, 0, 0, 11, 0, 0,  &
      0, 0, 0, 0,  &
  ! tests 97-112
      0, 0, 0, 0, 0, 0, 0, 0, 23, 0, 29, 0,  &
      0, 0, 0, 0,  &
  ! tests 113-128
      22, 20, 18, 0,  &
  ! tests 129-145
      9, 0, 11, 0,  &
  ! tests 145-160
      0, 11, 0, 0, 0, 0, 0, 0, 0, 9, 0, 0,  &
      0, 0, 0, 0,  &
  ! tests 161-176
      0, 0, 0, 0, 0, 0, 0, 0, 9, 0, 11, 0,  &
      0, 0, 0, 0,  &
  ! tests 177-192
      0, 0, 0, 0, 0, 0, 0, 0, 23, 0, 29, 0,  &
      0, 0, 0, 0,  &
  ! tests 193-196
      18, 20, 22, 0, &
  ! tests 173-176
     20, 23, 26, 29,  &
  ! tests  177-180
     20, 23, 26, 29,  &
  ! tests 181-184
      23, 26, 29, 0,  &
  ! tests 185-188
      0, 20, 23, 26,  &
  ! tests 189-192
      0, 5, 6, 7,  &
  ! tests 193-196
      8, 9, 10, 11,  &
  ! tests 197-200
      8, 11, 14, 17,  &
  ! tests 201-204
      0, 8, 11, 14,  &
  ! tests 205-208
      9, 10, 11, 0/

  results = -1

  ! tests 1-4
  arr3=0
  arr3 = matmul(arr1,arr2)
  call assign_result(1,4,arr3,results)
  !print *,arr3

  ! tests 5-8
  arr3=0
  arr3(2:4) = matmul(arr1(2:4,:),arr2)
  call assign_result(5,8,arr3,results)
  !print *,arr3

  ! tests 9-12
  arr3=0
  arr3(1:3) = matmul(arr1(2:4,:),arr2)
  call assign_result(9,12,arr3,results)
  !print *,arr3

  !tests 13-16
  arr3=0
  arr3(2:4) = matmul(arr1(1:3,:),arr2)
  call assign_result(13,16,arr3,results)
  !print *,arr3

  !tests 17-20
  arr3=0
  arr3(2:4) = matmul(arr1(2:4,1:2),arr2(1:2))
  call assign_result(17,20,arr3,results)
  !print *,arr3

  !tests 21-24
  arr3=0
  arr3 = matmul(arr1(:,2:3),arr2(1:2))
  call assign_result(21,24,arr3,results)
  !print *,arr3

  !tests 25-28
  arr3=0
  arr3 = matmul(arr1(:,1:2),arr2(2:3))
  call assign_result(25,28,arr3,results)
  !print *,arr3

  !tests 29-32
  arr3=0
  arr3(2:4)  = matmul(arr1(1:3,1:2),arr2(2:3))
  call assign_result(29,32,arr3,results)
  !print *,arr3

  !tests 33-36
  arr3=0
  arr3(1:3)  = matmul(arr1(2:4,2:3),arr2(1:2))
  call assign_result(33,36,arr3,results)
  !print *,arr3

  !tests 37-40
  arr3=0
  arr3(1:3) = matmul(arr1(2:4,1:3:2),arr2(1:3:2))
  call assign_result(37,40,arr3,results)
  !print *,arr3

  !tests 41-44
  arr3=0
  arr3(2:4:2)  = matmul(arr1(1:3:2,1:2),arr2(2:3))
  call assign_result(41,44,arr3,results)
  !print *,arr3

  !tests 45-48
  arr3=0
  arr3(1:3:2)  = matmul(arr1(2:4:2,2:3),arr2(1:2))
  call assign_result(45,48,arr3,results)
  !print *,arr3

  !tests 49-64
  arr4=0
  arr4(2,1:3:2)  = matmul(arr1(2:4:2,2:3),arr2(1:2))
  call assign_result(49,64,arr4,results)
  !print *,arr4

  !tests 65-80
  arr4=0
  arr4(1:3:2,3)  = matmul(arr1(2:4:2,2:3),arr2(1:2))
  call assign_result(65,80,arr4,results)
  !print *,arr4

  !tests 81-96
  arr7=0
  arr7(0,0:2:2)  = matmul(arr5(1:3:2,0:1),arr6(-3:-2))
  call assign_result(81,96,arr7,results)
  !print *,arr7

  !tests 97-112
  arr7=0
  arr7(-1:1:2,2)  = matmul(arr5(1:3:2,0:1),arr6(-2:-1))
  call assign_result(97,112,arr7,results)
  !print *,arr7

  !tests 113-116
  arr3=0
  arr3(3:1:-1) = matmul(arr1(2:4,3:1:-2),arr2(3:1:-2))
  call assign_result(113,116,arr3,results)
  !print *,arr3

  !tests 117-120
  arr3=0
  arr3(3:1:-2)  = matmul(arr1(4:2:-2,2:3),arr2(1:2))
  call assign_result(117,120,arr3,results)
  !print *,arr3

  !tests 121,136
  arr4=0
  arr4(2,3:1:-2)  = matmul(arr1(2:4:2,2:3),arr2(1:2))
  call assign_result(121,136,arr4,results)
  !print *,arr4

  !tests 137-152
  arr4=0
  arr4(3:1:-2,3)  = matmul(arr1(4:2:-2,2:3),arr2(1:2))
  call assign_result(137,152,arr4,results)
  !print *,arr4

  !tests 153-168
  arr7=0
  arr7(1:-1:-2,2)  = matmul(arr5(3:1:-2,0:1),arr6(-2:-1))
  call assign_result(153,168,arr7,results)
  !print *,arr7

  !tests 169-172
  arr3=0
  arr3(1:3) = matmul(arr1(2:4,3:1:-2),arr2(3:1:-2))
  call assign_result(169,172,arr3,results)
  !print *,arr3

  arr12 = 0

  !print *,"tests 173-176"
  arr10=0
  arr10 = arr12 + matmul(arr8,arr9)
  call assign_result(173,176,arr10,results)
  !print *,arr10

  !print *,"tests 177-180"
  arr10=0
  arr10 = arr12 +  matmul(arr11,arr9)
  call assign_result(177,180,arr10,results)
  !print *,arr10

  !print *,"tests 181-184"
  arr10=0
  arr10(2:4) = arr12(2:4) + matmul(arr8(3:5,:),arr9)
  call assign_result(181,184,arr10,results)
  !print *,arr10

  !print *,"tests 185-188"
  arr10=0
  arr10(3:5) = arr12(3:5) + matmul(arr8(2:4,:),arr9)
  call assign_result(185,188,arr10,results)
  !print *,arr10

  !print *,"tests 189-192"
  arr10=0
  arr10(3:5) = arr12(3:5) + matmul(arr8(3:5,1:2),arr9(2:3))
  call assign_result(189,192,arr10,results)
  !print *,arr10

  !print *,"tests 193-196"
  arr10=0
  arr10 = arr12 + matmul(arr8(:,2:3),arr9(2:3))
  call assign_result(193,196,arr10,results)
  !print *,arr10

  !print *,"tests 197-200"
  arr10=0
  arr10 = arr12 + matmul(arr8(:,1:2),arr9(3:4))
  call assign_result(197,200,arr10,results)
  !print *,arr10

  !print *,"tests 201-204"
  arr10=0
  arr10(3:5)  = arr12(3:5) + matmul(arr8(2:4,1:2),arr9(3:4))
  call assign_result(201,204,arr10,results)
  !print *,arr10

  !print *,"tests 205-208"
  arr10=0
  arr10(2:4)  = arr12(2:4) + matmul(arr8(3:5,2:3),arr9(2:3))
  call assign_result(205,208,arr10,results)
  !print *,arr10

  call check(results, expect, NbrTests)

end program

subroutine assign_result(s_idx, e_idx , arr, rslt)
  integer*4, dimension(1:e_idx-s_idx+1) :: arr
  integer*4, dimension(e_idx) :: rslt
  integer:: s_idx, e_idx

  rslt(s_idx:e_idx) = arr

end subroutine


      subroutine hfti (a,mda,m,n,b,mdb,nb,tau,krank,rnorm,h,g,ip)
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	   solve least squares problem using algorithm, hfti.
c
      dimension a(mda,n),b(mdb,nb),h(n),g(n),rnorm(nb)
      integer ip(n)
      double precision sm,dzero
      szero=0.
      dzero=0.d0
      factor=0.001
c
      k=0
      ldiag=min0(m,n)
      if (ldiag.le.0) go to 270
	  do 80 j=1,ldiag
	  if (j.eq.1) go to 20
c
c     update squared column lengths and find lmax
c    ..
	  lmax=j
	      do 10 l=j,n
	      h(l)=h(l)-a(j-1,l)**2
	      if (h(l).gt.h(lmax)) lmax=l
   10	      continue
	  if(diff(hmax+factor*h(lmax),hmax)) 20,20,50
c
c     compute squared column lengths and find lmax
c    ..
   20	  lmax=j
	      do 40 l=j,n
	      h(l)=0.
		  do 30 i=j,m
   30		  h(l)=h(l)+a(i,l)**2
	      if (h(l).gt.h(lmax)) lmax=l
   40	      continue
	  hmax=h(lmax)
c    ..
c     lmax has been determined
c
c     do column interchanges if needed.
c    ..
   50	  continue
	  ip(j)=lmax
	  if (ip(j).eq.j) go to 70
	      do 60 i=1,m
	      tmp=a(i,j)
	      a(i,j)=a(i,lmax)
   60	      a(i,lmax)=tmp
	  h(lmax)=h(j)
c
c     compute the j-th transformation and apply it to a and b.
c    ..
c       print 69, "call h12(1,", j, ",", j, "+1,", m, ",a(1,", j,       &
c    &   "),1,h(", j, "),a(1,", j, "+1),1,", mda, ",", n, "-", j, ")"
c  69   format(9(A,I3),A)
   70	  call h12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j)

c       print 69, "call h12(2,", j, ",", j, "+1,", m, ",a(1,", j,       &
c    &   "),1,h(", j, "),b,1,",mdb, ",", mdb, ")"
c  79   format(7(A,I3),A)
   80	  call h12 (2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb)
c
c     determine the pseudorank, k, using the tolerance, tau.
c    ..
	  do 90 j=1,ldiag
	  if (abs(a(j,j)).le.tau) go to 100
   90	  continue
      k=ldiag
      go to 110
  100 k=j-1
  110 kp1=k+1
c
c     compute the norms of the residual vectors.
c
      if (nb.le.0) go to 140
	  do 130 jb=1,nb
	  tmp=szero
	  if (kp1.gt.m) go to 130
	      do 120 i=kp1,m
  120	      tmp=tmp+b(i,jb)**2
  130	  rnorm(jb)=sqrt(tmp)
  140 continue
c					    special for pseudorank = 0
      if (k.gt.0) go to 160
      if (nb.le.0) go to 270
	  do 150 jb=1,nb
	      do 150 i=1,n
  150	      b(i,jb)=szero
      go to 270
c
c     if the pseudorank is less than n compute householder
c     decomposition of first k rows.
c    ..
  160 if (k.eq.n) go to 180
	  do 170 ii=1,k
	  i=kp1-ii

c       print 169, "call h12(1,", i, ",", kp1,",", n, ",a(", i,         &
c    &   ",1)", mda, ",g(", i, "),a,", mda, ",1,", i, "-1)"
c 169   format(8(A,I3),A)
  170	  call h12 (1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1)
  180 continue
c
c
      if (nb.le.0) go to 270
	  do 260 jb=1,nb
c
c     solve the k by k triangular system.
c    ..
	      do 210 l=1,k
	      sm=dzero
	      i=kp1-l
	      if (i.eq.k) go to 200
	      ip1=i+1
		  do 190 j=ip1,k
  190		  sm=sm+a(i,j)*dble(b(j,jb))
  200	      sm1=sm
  210	      b(i,jb)=(b(i,jb)-sm1)/a(i,i)
c
c     complete computation of solution vector.
c    ..
	  if (k.eq.n) go to 240
	      do 220 j=kp1,n
  220	      b(j,jb)=szero
	      do 230 i=1,k
c           print 169, "call h12(2,", i, ",", kp1,",", n, ",a(", i,     &
c    &      ",1)", mda, ",g(", i, "),b(1,", jb, ",1,", mdb, ",1)"
  230	      call h12 (2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1)
c
c      re-order the solution vector to compensate for the
c      column interchanges.
c    ..
  240	      do 250 jj=1,ldiag
	      j=ldiag+1-jj
	      if (ip(j).eq.j) go to 250
	      l=ip(j)
	      tmp=b(l,jb)
	      b(l,jb)=b(j,jb)
	      b(j,jb)=tmp
  250	      continue
  260	  continue
c    ..
c     the solution vectors, x, are now
c     in the first  n  rows of the array b(,).
c
  270 krank=k
      return
      end


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE VINTER (MXND, XN, YN, N1, N2, N3, XOLD, YOLD,
     &   XNEW, YNEW, VCROSS)
C***********************************************************************

C  SUBROUTINE VINTER = FINDS WHERE A VECTOR FROM N1 TO N2
C                      INTERSECTS THE VECTOR FROM N3 TO (XOLD, YOLD)

C***********************************************************************

C  NOTE:  THIS INTERSECTION ROUTINE IS BASED ON AN ALGORITHM GIVEN
C         IN THE BOOK "GEOMETRIC MODELING" BY MICHAEL E. MORTENSON ON
C         PAGES 319 - 320.

C***********************************************************************

      DIMENSION XN (MXND), YN (MXND)

      LOGICAL VCROSS

      VCROSS = .FALSE.

C  SET UP THE FIRST LINE'S VECTORS (A AND B)

      XA = XN (N1)
      YA = YN (N1)
      XB = XN (N2) - XN (N1)
      YB = YN (N2) - YN (N1)

C  SET UP THE SECOND LINE'S VECTORS (C AND D)

      XC = XN (N3)
      YC = YN (N3)
      XD = XOLD - XN (N3)
      YD = YOLD - YN (N3)

C  NOW USE THE VECTORS AND SOLVE FOR W.
C  W IS THE PROPORTION OF THE DISTANCE ALONG THE VECTOR D
C  WHERE THE INTERSECTION OCCURS.  LIKEWISE U IS THE PROPORTIONAL
C  DISTANCE ALONG THE VECTOR B FOR THE INTERSECTION.

      DENOM = (YB * XD) - (XB * YD)

C  CHECK FOR SPECIAL PARALLEL CASE - THE DENOMINATOR IS EQUAL TO ZERO.

      IF (DENOM .NE. 0.) THEN

C  GET INTERSECTION LOCATION

         W = ( (YC * XB) - (XB * YA) - (XC * YB) + (YB * XA) ) / DENOM

C  GET THE U VALUE TO CONFIRM.

         IF (XB .NE. 0.) THEN
            U = ( XC + (W * XD) - XA ) / XB
         ELSE
            U = ( YC + (W * YD) - YA ) / YB
         ENDIF

C  CALCULATE THE INTERSECTION POINT BASED ON SIMILAR TRIANGLES

         XNEW = ( (XA + (XB * U)) + (XC + (XD * W)) ) * .5
         YNEW = ( (YA + (YB * U)) + (YC + (YD * W)) ) * .5
         VCROSS = .TRUE.
      ENDIF

      RETURN

      END


module odes

use parameters
use constants

implicit none

private

public derivs,density_profile

contains

subroutine derivs(y,c, dy)

!Arguments
real(kind=dp), intent(IN), dimension(6) :: y
real(kind=dp), intent(OUT), dimension(6) :: dy !deriatives
real(kind=dp), intent(in), dimension(4) :: c

!Other
real(kind=dp) :: r, theta,pr,ptheta
real(kind=dp) :: L, kappa
real(kind=dp) :: delta, sigma,r2,ctheta, stheta, SD, B2
real(kind=dp) :: f,g,f1,g1
real(kind=dp) :: plasma_pr, plasma_ptheta

!Load the variables and constants
r = y(1) ; theta = y(2) ; pr = y(5) ; ptheta=y(6)
L = c(1) ; kappa = c(2) ; B2 = c(4)

!Define some useful stuff
r2 = r**2
ctheta = cos(theta)
stheta = sin(theta)

delta = r2 - 2.0_dp*r + a2
sigma = r2 -a2*ctheta
SD = sigma*delta

!Set of ODEs to solve
dy(1) = pr*delta/sigma
dy(2) = ptheta / sigma
dy(3) = (2.0_dp*a*r + (sigma-2.0_dp*r)*L/stheta**2) / (SD)
dy(4) = 1.0_dp + (2.0_dp*r*(r2 + a2)-2.0_dp*a*r*L) /SD

call density_profile(r,theta,f,g,f1,g1)

plasma_pr = -B2*(f1*delta/2.0_dp + (r-1.0_dp)*f) / SD
plasma_ptheta = -B2*g1/(2.0_dp*sigma)

dy(5) = (-kappa*(r-1.0_dp) +2.0_dp*r*(r2 + a2) - 2.0_dp*a*L)/SD - 2.0_dp*pr**2*(r-1.0_dp)/sigma + plasma_pr
dy(6) = ctheta*stheta*(L**2/stheta**4 - a2) / sigma + plasma_ptheta

end subroutine derivs

subroutine density_profile(r,theta,f,g,f1,g1)
!Arguments
real(kind=dp), intent(in) :: r,theta
real(kind=dp), intent(out) :: f,g,f1,g1

f = r**(0.90_dp)
g = 0.0_dp

f1 = 0.90_dp*r**(-0.10_dp)
g1 = 0.0_dp

end subroutine density_profile

end module odes


      SUBROUTINE DANG(A1,A2,B1,B2,RCOS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
**********************************************************************
*
*    DANG  DETERMINES THE ANGLE BETWEEN THE POINTS (A1,A2), (0,0),
*          AND (B1,B2).  THE RESULT IS PUT IN RCOS.
*
**********************************************************************
      PI=2.0D0* ASIN(1.0D00)
      ZERO=1.0D-6
      IF( ABS(A1).LT.ZERO.AND. ABS(A2).LT.ZERO) GO TO 10
      IF( ABS(B1).LT.ZERO.AND. ABS(B2).LT.ZERO) GO TO 10
      ANORM=1.0D0/ SQRT(A1**2+A2**2)
      BNORM=1.0D0/ SQRT(B1**2+B2**2)
      A1=A1*ANORM
      A2=A2*ANORM
      B1=B1*BNORM
      B2=B2*BNORM
      SINTH=(A1*B2)-(A2*B1)
      COSTH=A1*B1+A2*B2
      IF(COSTH.GT.1.0D0) COSTH=1.0D0
      IF(COSTH.LT.-1.0D0) COSTH=-1.0D0
      RCOS= ACOS(COSTH)
      IF( ABS(RCOS).LT.4.0D-4) GO TO 10
      IF(SINTH.GT.0.D0) RCOS=4.0D0* ASIN(1.0D00)-RCOS
      RCOS=-RCOS
      RETURN
   10 RCOS=0.0D0
      RETURN
      END