!!# FUNCTION MODULE: <FUN_xyREFLECT>
MODULE FUN_xyREFLECT

!!## PURPOSE
!! Compute the reflections in 2D.

!!## INFO
!! author : William Wieselquist [waw]
!! contact: william.wieselquist@gmail.com

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

!!## EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_2_Rsp => c_2     !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_2_Rdp => c_2     !!((02-A-PAR_Constants_Rdp.f90))

!!## EXTERNAL PROCEDURES
USE FUN_xyDOT                                  !!((03-A-FUN_xyDOT.f90))
USE FUN_xySDIST                                !!((03-A-FUN_xySDIST.f90))
USE FUN_xyDIRECTION                            !!((04-B-FUN_xyDIRECTION.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyREFLECT_PnV
 MODULE PROCEDURE xyREFLECT_PnV_Rsp
 MODULE PROCEDURE xyREFLECT_PnV_Rdp
END INTERFACE

INTERFACE xyREFLECT_PnU
 MODULE PROCEDURE xyREFLECT_PnU_Rsp
 MODULE PROCEDURE xyREFLECT_PnU_Rdp
END INTERFACE

INTERFACE xyREFLECT_PnP
 MODULE PROCEDURE xyREFLECT_PnP_Rsp
 MODULE PROCEDURE xyREFLECT_PnP_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyREFLECT_PnV
PUBLIC :: xyREFLECT_PnU
PUBLIC :: xyREFLECT_PnP

CONTAINS

PURE FUNCTION xyREFLECT_PnP_Rsp( Pn , P ) RESULT(xyP)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_2 = c_2_Rsp
INCLUDE "05-B-FUN_xyREFLECT_PnP.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyREFLECT_PnP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyREFLECT_PnP_Rdp( Pn , P ) RESULT(xyP)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_2 = c_2_Rdp
INCLUDE "05-B-FUN_xyREFLECT_PnP.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyREFLECT_PnP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyREFLECT_PnU_Rsp( Pn , V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_2 = c_2_Rsp
INCLUDE "05-B-FUN_xyREFLECT_PnV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyREFLECT_PnV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyREFLECT_PnU_Rdp( Pn , V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_2 = c_2_Rdp
INCLUDE "05-B-FUN_xyREFLECT_PnV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyREFLECT_PnV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyREFLECT_PnV_Rsp( Pn , V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_2 = c_2_Rsp
INCLUDE "05-B-FUN_xyREFLECT_PnV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyREFLECT_PnV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyREFLECT_PnV_Rdp( Pn , V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_2 = c_2_Rdp
INCLUDE "05-B-FUN_xyREFLECT_PnV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyREFLECT_PnV.f90.bdy"
!!--end--
END FUNCTION

END MODULE


module mod_fold_functions

implicit none

public

contains

pure integer(kind=int8) function sum_i1(x,y) result(res)
  use iso_fortran_env,only:int8
  integer(kind=int8),intent(in) :: x,y
  res = x + y
endfunction sum_i1

pure integer(kind=int16) function sum_i2(x,y) result(res)
  use iso_fortran_env,only:int16
  integer(kind=int16),intent(in) :: x,y
  res = x + y
endfunction sum_i2

pure integer(kind=int32) function sum_i4(x,y) result(res)
  use iso_fortran_env,only:int32
  integer(kind=int32),intent(in) :: x,y
  res = x + y
endfunction sum_i4

pure integer(kind=int64) function sum_i8(x,y) result(res)
  use iso_fortran_env,only:int64
  integer(kind=int64),intent(in) :: x,y
  res = x + y
endfunction sum_i8

pure real(kind=real32) function sum_r4(x,y) result(res)
  use iso_fortran_env,only:real32
  real(kind=real32),intent(in) :: x,y
  res = x + y
endfunction sum_r4

pure real(kind=real64) function sum_r8(x,y) result(res)
  use iso_fortran_env,only:real64
  real(kind=real64),intent(in) :: x,y
  res = x + y
endfunction sum_r8

pure real(kind=real128) function sum_r16(x,y) result(res)
  use iso_fortran_env,only:real128
  real(kind=real128),intent(in) :: x,y
  res = x + y
endfunction sum_r16

pure complex(kind=real32) function sum_c4(x,y) result(res)
  use iso_fortran_env,only:real32
  complex(kind=real32),intent(in) :: x,y
  res = x + y
endfunction sum_c4

pure complex(kind=real64) function sum_c8(x,y) result(res)
  use iso_fortran_env,only:real64
  complex(kind=real64),intent(in) :: x,y
  res = x + y
endfunction sum_c8

pure complex(kind=real128) function sum_c16(x,y) result(res)
  use iso_fortran_env,only:real128
  complex(kind=real128),intent(in) :: x,y
  res = x + y
endfunction sum_c16

endmodule mod_fold_functions

program test_foldl
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional
use mod_fold_functions

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

complex(kind=real32),dimension(:),allocatable :: c4
complex(kind=real64),dimension(:),allocatable :: c8
complex(kind=real128),dimension(:),allocatable :: c16
complex(kind=real64) :: c8_start
complex(kind=real128) :: c16_start

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

tests(n) = assert(foldl(sum_i1,0_int8,[1_int8,2_int8,3_int8,4_int8,5_int8]) == 15,&
                        'foldl, int8')
n = n + 1

tests(n) = assert(foldl(sum_i2,0_int16,[1_int16,2_int16,3_int16,4_int16,5_int16]) == 15,&
                        'foldl, int16')
n = n + 1

tests(n) = assert(foldl(sum_i4,0_int32,[1_int32,2_int32,3_int32,4_int32,5_int32]) == 15,&
                        'foldl, int32')
n = n + 1

tests(n) = assert(foldl(sum_i8,0_int64,[1_int64,2_int64,3_int64,4_int64,5_int64]) == 15,&
                        'foldl, int64')
n = n + 1

tests(n) = assert(foldl(sum_r4,0._real32,[1._real32,2._real32,3._real32,4._real32,5._real32]) == 15,&
                        'foldl, real32')
n = n + 1

tests(n) = assert(foldl(sum_r8,0._real64,[1._real64,2._real64,3._real64,4._real64,5._real64]) == 15,&
                        'foldl, real64')
n = n + 1

tests(n) = assert(foldl(sum_r16,0._real128,[1._real128,2._real128,3._real128,4._real128,5._real128]) == 15,&
                        'foldl, real128')
n = n + 1

c4 = arange(cmplx(1,0),cmplx(5,0))
c8 = c4
c16 = c4

c8_start = cmplx(0,0)
c16_start = c8_start

tests(n) = assert(foldl(sum_c4,cmplx(0.,0.),c4) == cmplx(15,0),&
                  'foldl, complex real32')
n = n + 1

tests(n) = assert(foldl(sum_c8,c8_start,c8) == cmplx(15._real64,0._real64),&
                  'foldl, complex real64')
n = n + 1

tests(n) = assert(foldl(sum_c16,c16_start,c16) == cmplx(15._real128,0._real128),&
                  'foldl, complex real128')
n = n + 1

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

endprogram test_foldl


	SUBROUTINE IN_CINT ( cint, grid, npts, gmin, gmax, cval, nv,
     +			     clbl, rint, iret )
C************************************************************************
C* IN_CINT								*
C*									*
C* This subroutine processes the user contour specification.  If	*
C* GMIN or GMAX is set to the missing value, the values in the grid	*
C* are used to compute GMIN and GMAX.  GRID is not used if GMIN and	*
C* GMAX are not missing.  An array of values is returned.		*
C* If a number-of-digits, ndig, is specified, the subroutine will pad	*
C* the beginning of the integer part of the label with enough zeroes	*
C* to expand that part of the label to have ndig characters, not	*
C* including the minus sign, if any.					*
C*									*
C* CINT is expected to be of the form:					*
C*									*
C*	    increment/minimum/maximum/ndigits				*
C*	or								*
C*	    value1;value2;...;valueN///ndigits				*
C*	or								*
C*	    value1=label1;value2=label2;...;valueN=labelN		*
C*									*
C* where the minimum and maximum give the range for the contours. If	*
C* the minimum equals the maximum, a single contour with that value	*
C* is assumed.  In the latter specification, the specified contour	*
C* levels are used, and the minimum and maximum are ignored.		*
C* The fourth parameter, ndigits, forces all labels with fewer than     *
C* ndigits digits in the integer portion of the label to expand to      *
C* ndigits by padding the leading digit with zeroes.                    *
C*									*
C* IN_CINT ( CINT, GRID, NPTS, GMIN, GMAX, CVAL, NV, CLBL, RINT, IRET )	*
C*									*
C* Input parameters:							*
C*	CINT		CHAR*		Input for contours		*
C*	GRID (NPTS)	REAL		Array of data			*
C*	NPTS		INTEGER		Number of grid values		*
C*									*
C* Input and output parameters:						*
C*	GMIN		REAL		Minimum grid value		*
C*	GMAX		REAL		Maximum grid value		*
C*									*
C* Output parameters:							*
C*	CVAL (*)	REAL		List of contour levels		*
C*	NV		INTEGER		Number of contour levels	*
C*	CLBL (*)	CHAR*		Contour labels			*
C*	RINT		REAL		Calculated contour interval	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -3 = invalid input		*
C*					 -4 = constant grid		*
C**									*
C* Log:									*
C* K. Brill/GSC		05/90						*
C* G. Krueger/EAI	07/93	Modified to return RINT			*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C* T. Piper/GSC		 3/99	Corrected prolog			*
C* T. Lee/SAIC		12/01	Increased substr string length to LLMXLN*
C* C. Bailey/HPC	 6/06	Modified to return contour labels	*
C* S. Jacobs/NCEP	11/06	Fixed bug when min=max			*
C* R. Jones/NCEP	12/06	Added number of digits specification	*
C* S. Schotz/NCEP       2/07    Correct case where no cint is set
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	cint
	REAL		grid (*), cval (*)
	CHARACTER*(*)	clbl (*)
C*
	CHARACTER	substr (4) * (LLMXLN), cname (LLCLEV)*24,
     +			carr(2)*24
        CHARACTER       clab1*24, clab2*24
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	nv = 0
	num = 0
C
C*	Break CINT into 4 substrings.
C
	CALL ST_CLST ( cint, '/', ' ', 4, substr, nst, ier )
	IF ( ier .ne. 0 ) THEN
	    iret = -3
	    CALL ER_WMSG ( 'IN', iret, cint, ier )
	    RETURN
	END IF
C
C*	Convert the fourth item to an integer. Check for valid values
C*	for the number of leading zeroes to be added to a data value.
C
	CALL ST_NUMB ( substr (4), npad, ier )
	IF  ( ( npad .lt. 0 ) .or. ( npad .gt. 9 ) )  npad = 0
C
C*	Look at the first substring to see if it contains a list of
C*	values or a single number giving the increment.
C
	CALL ST_CLST ( substr (1), ';', ' ', LLCLEV, cname, nv, ier )
	IF ( ier .ne. 0 ) THEN
	    iret = -3
	    CALL ER_WMSG ( 'IN', iret, cint, ier )
	END IF
C
C	Check for case where no contour interval is specified
C
	IF (nv .eq. 0) THEN
C
C	   Initilize contour interval when not specified
C
	   cval(1) = 0.0
	ELSE
C
C*	   Loop through each contour value
C
	   DO i = 1, nv
C
C*	      Separate contour value from label if appropriate
C
	      CALL ST_CLST ( cname (i), '=', ' ', 2, carr, num, ier )
C
C*	      Convert contour value string into a real number
C
       	      CALL ST_CRNM(carr(1), rnum, ier )
	      cval(i) = rnum
C
C*	      Check to see if contour label specified with value.
C*            If not, use contour value as label
C
	      IF (num .gt. 1) then
		clbl(i) = carr(2)
	      ELSE
		clbl(i) = carr(1)
	      END IF
	  END DO
	END IF
C
        IF ( nv .gt. 1 ) THEN
	    rcint = 0.0
	    cmin = 0.0
	    cmax = 0.0
	  ELSE
C
C*	    Contour levels have not been listed.
C*	    Decode range from second and third substrings.
C
	    CALL ST_CRNM ( substr (2), cmin, ier )
	    CALL ST_CRNM ( substr (3), cmax, ier )
C
C*	    Check for single contour level.
C
	    IF ( cmin .eq. cmax .and. .not. ERMISS ( cmin ) ) THEN
C
C*              Check if label has been specified, if not set cval(1)
C*              and contour label to cmin
C
	        cval (1) = cmin
		IF (num .le. 1) then
		    CALL GR_LABL(cval(1), 0, 0, clbl(1), nchar, ier)
		END IF
		nv   = 1
	      ELSE
C
C*		Generate multiple contour levels.
C
		IF ( ERMISS ( gmin ) .or. ERMISS ( gmax ) ) THEN
C
C*		    Find grid maximum and minimum values.
C
		    gmin =  1.E31
		    gmax = -1.E31
		    DO i = 1, npts
			IF ( .not. ERMISS ( grid (i) ) ) THEN
			  IF ( grid (i) .lt. gmin ) gmin = grid (i)
			  IF ( grid (i) .gt. gmax ) gmax = grid (i)
			END IF
		    END DO
		    IF ( gmin .eq. 1.e31 .or. gmin .eq. gmax ) THEN
			iret = -4
			CALL ER_WMSG ( 'IN', iret, ' ', ier )
			RETURN
		    END IF
	        END IF
C
C*		Specified contour label strings not allowed.
C
		rcint = cval (1)
		CALL GR_CLVL ( LLCLEV, cmin, cmax, rcint, gmin, gmax,
     +				nv, cval, rint, iret )
		IF ( iret .ne. 0 )  THEN
		    CALL ER_WMSG ( 'GR', iret, ' ', ier )
		    iret = -3
		    CALL ER_WMSG ( 'IN', iret, ' ', ier )
		    RETURN
		END IF
C
C*		Convert contour values to strings
C
		DO i = 1, nv
		    CALL GR_LABL(cval(i), 0, 0, clbl(i), nchar, ier)
		END DO
	    END IF
	END IF
C
C*	Add zero-padding to the contour values.
C
	IF  ( npad .gt. 0 )  THEN
	    DO  ii = 1, nv
		CALL ST_NULL ( clbl(ii), clab1, lenc, ier )
		CALL CST_ZPAD ( clab1, npad, clab2, ier )
		CALL ST_RNUL ( clab2, clbl(ii), lenc, ier )
	    END DO
	END IF
C*
	RETURN
	END


      program main
      implicit none
! number of components
      integer ncom
      parameter (ncom=4)
! number of particles
      integer npart
      parameter (npart=2)
! Detail of particles
      integer partlst(npart)
      data partlst/-11,11/
! number of beam type
      integer nbeam
      parameter (nbeam=2)
! detail of beam id
      integer beamlst(nbeam)
      data beamlst/-11,11/
! nodes of the y grid
      integer nny
      parameter (nny=100)
! nodes of the z grid
      integer nnz
      parameter (nnz=20)
! the reference scale
      real*8 Qref
! the scale (temporary variable)
      real*8 Q
! the electron mass
      real*8 me
      parameter (me=0.511d-3)
! the electric coupling
      real*8 aem
! this is the Gmu scheme
      parameter (aem=1.d0/132.2332d0)
! grid nodes and grids
      real*8 yv(nny),zv(nnz)
      real*8,dimension(:,:,:,:,:), allocatable :: grids
c
      integer iny,inz,icom,ipart,ibeam
      integer i1,i2,i,j
c     integer ifakegrid
      real*8 ylow,yupp,zlow,zupp
c     real*8 alst,q0st,alxm,q0xm
      real*8 jkb,x
      real*8 eepdf_tilde_calc,eepdf_tilde_factor
!     temporary variables
      real*8 tv1,tv2,tvy
c
      ylow=1.d-6
      yupp=1d0-1.d-8
      zlow=log(1.d0/me)
      zupp=log(10000.d0/me)
      Qref=1d0
      allocate(grids(nny,nnz,ncom,npart,nbeam))
c     electron part
      do iny=1,nny
c     Using linear grid as the first step
c     More points at the end
      tvy=dfloat(iny-1)/dfloat(nny-1)
c     yv(iny)=(1.d0-(1.d0-tvy)**3.d0)*(yupp-ylow)+ylow
      yv(iny)=tvy*tvy*(6.d0+tvy*(-8.d0+3.d0*tvy))*(yupp-ylow)+ylow
c     yv(iny)=tvy*(3.d0-tvy*2.d0)*(yupp-ylow)+ylow
      do inz=1,nnz
      zv(inz)=dfloat(inz-1)/dfloat(nnz-1)*(zupp-zlow)+zlow
      do icom=1,ncom
      do ipart=1,npart
      do ibeam=1,nbeam
      Q=exp(zv(inz))*me
      tv1=eepdf_tilde_calc(yv(iny),Q*Q,icom
     #     ,partlst(ipart),beamlst(ibeam))
      tv2=eepdf_tilde_factor(yv(iny),Q*Q,icom
     #     ,partlst(ipart),beamlst(ibeam))
      grids(iny,inz,icom,ipart,ibeam)=tv1/tv2
!     print *,yv(iny),tv1,tv2,tv1/tv2
      enddo
      enddo
      enddo
      enddo
      enddo
c
      open(unit=10,file='eepdf.f',status='unknown')
c
      write(10,'(a)')
     #'      function eepdf_tilde(y,Q2,icom,ipart,ibeam)',
     #'      implicit none',
     #'      real*8 eepdf_tilde',
     #'      real*8 Q2,Qref,me',
     #'      integer icom,ipart,ibeam',
     #'      real*8 tmp,cstmin,cxmmin,cxmmax',
     #'      integer i,id0,listmin,lixmmin,lixmmax',
     #'      logical firsttime,check,T,F,grid(21)',
     #'      parameter (T=.true.)',
     #'      parameter (F=.false.)',
     #'      real*8 eepdf_tilde_factor'
      write(10,'(a)')
     #'      real*8 y,z',
     #'      real*8 ylow,yupp,zlow,zupp',
     #'      real*8 jkb'
      write(10,'(a,d15.8,a,d15.8,a)')
     #'      parameter (ylow=',ylow,',yupp=',yupp,')'
      write(10,'(a,d15.8,a,d15.8,a)')
     #'      parameter (zlow=',zlow,',zupp=',zupp,')'
      write(10,'(a,d15.8,a,d15.8,a)')
     #'      parameter (Qref=',Qref,',me=',me,')'
      do ipart=1,npart
      do ibeam=1,nbeam
      do icom=1,ncom
!     Use ipart instead of the real PID, as we have negative PID
        write(10,'(a,i0,a,i0,a,i0)')
     #'      real*8 eepdf_',icom,'_',ipart,'_',ibeam
      enddo
      enddo
      enddo
      write(10,'(a)')
     #'      z=0.5d0*log(Q2/me/me)'
!     No check now
      do icom=1,ncom
      if(icom.eq.1)then
        write(10,'(a)')
     #'      if(icom.eq.1)then'
      else
        write(10,'(a,i0,a)')
     #'      else if(icom.eq.',icom,')then'
      endif
        do ipart=1,npart
        if(ipart.eq.1)then
          write(10,'(a,i0,a)')
     #'        if(ipart.eq.',partlst(ipart),')then'
        else
          write(10,'(a,i0,a)')
     #'        else if(ipart.eq.',partlst(ipart),')then'
        endif
        do ibeam=1,nbeam
        if(ibeam.eq.1)then
          write(10,'(a,i0,a)')
     #'          if(ibeam.eq.',beamlst(ibeam),')then'
        else
          write(10,'(a,i0,a)')
     #'          else if(ibeam.eq.',beamlst(ibeam),')then'
        endif
        write(10,'(a,i0,a,i0,a,i0,a)')
     #'          tmp=eepdf_',icom,'_',ipart,'_',ibeam,'(y,z)'
        enddo
        write(10,'(a)')
     #'          else',
     #'            tmp=0d0',
     #'          endif'

        enddo
        write(10,'(a)')
     #'        else',
     #'          tmp=0d0',
     #'        endif'
        enddo
        write(10,'(a)')
     #'      else',
     #'        tmp=0d0',
     #'      endif',
     #'      eepdf_tilde=tmp*eepdf_tilde_factor(y,Q2,icom,ipart,ibeam)',
     #'      end'
        write(10,'(a)')
     #'c',
     #'c',
     #'cccc',
     #'c',
     #'c'

         do icom=1,ncom
         do ipart=1,npart
         do ibeam=1,nbeam

         write(10,'(a,i0,a,i0,a,i0,a)')
     #'      function eepdf_',icom,'_',ipart,'_',ibeam,'(y,z)'
         write(10,'(a)')
     #'      implicit none'
         write(10,'(a,i1,a,i1,a,i0,a)')
     #'      real*8 eepdf_',icom,'_',ipart,'_',ibeam,',y,z'
         write(10,'(a)')
     #'      integer narg,nny,nnz',
     #'      parameter (narg=2)'
        write(10,'(a,i0,a)')
     #'      parameter (nny=',nny,')'
        write(10,'(a,i0,a)')
     #'      parameter (nnz=',nnz,')'
        write(10,'(a)')
     #'      integer iny,inz,nent(narg)',
     #'      real*8 tmp,dfint,ymap,zmap',
     #'      real*8 arg(narg),ent(nny+nnz)',
     #'      real*8 yv(nny),zv(nnz),gridv(nny,nnz)',
     #'      logical firsttime',
     #'      external dfint,ymap,zmap'
c
        write(10,'(a)')
     #'      data yv/'
        i1=nny/4
        i2=mod(nny,4)
        if(i2.eq.0)i1=i1-1
        do i=1,i1
        write(10,'(a,4(d15.8,1h,))')
     #'     #',(yv(j),j=1+(i-1)*4,i*4)
        enddo
        write(10,'(a,4(d15.8,a))')
     #'     #',(yv(j),',',j=1+i1*4,nny-1),yv(nny),'/'
c
        write(10,'(a)')
     #'      data zv/'
        i1=nnz/4
        i2=mod(nnz,4)
        if(i2.eq.0)i1=i1-1
        do i=1,i1
        write(10,'(a,4(d15.8,1h,))')
     #'     #',(zv(j),j=1+(i-1)*4,i*4)
        enddo
        write(10,'(a,4(d15.8,a))')
     #'     #',(zv(j),',',j=1+i1*4,nnz-1),zv(nnz),'/'
c
        do inz=1,nnz
        write(10,'(a,i3,a,i3,a)')
     #'      data (gridv(iny,',inz,'),iny=1,',nny,')/'
        i1=nny/4
        i2=mod(nny,4)
        if(i2.eq.0)i1=i1-1
        do i=1,i1
        write(10,'(a,4(d15.8,1h,))')
     #'     #',(grids(j,inz,icom,ipart,ibeam),j=1+(i-1)*4,i*4)
        enddo
        write(10,'(a,4(d15.8,a))')
     #'     #',(grids(j,inz,icom,ipart,ibeam),',',j=1+i1*4,nny-1),
     #    grids(nny,inz,icom,ipart,ibeam),'/'
        enddo
c
        write(10,'(a)')
     #'      data firsttime/.true./',
     #'      save',
     #'c',
     #'      if(firsttime)then',
     #'        firsttime=.false.',
     #'        nent(1)=nny',
     #'        nent(2)=nnz',
     #'        do iny=1,nny',
     #'          ent(iny)=ymap(yv(iny))',
     #'        enddo',
     #'        do inz=1,nnz',
     #'          ent(nny+inz)=zmap(zv(inz))',
     #'        enddo',
     #'      endif',
     #'      arg(1)=ymap(y)',
     #'      arg(2)=zmap(z)',
     #'      tmp=dfint(narg,arg,nent,ent,gridv)'
        write(10,'(a,i0,a,i0,a,i0,a)')
     #'      eepdf_',icom,'_',ipart,'_',ibeam,'=tmp'
        write(10,'(a)')
     #'      return',
     #'      end'
c
        write(10,'(a)')
     #'c',
     #'c',
     #'cccc',
     #'c',
     #'c'
c end of loops over itype and ipart
        enddo
        enddo
        enddo
c
        write(10,'(a)')
     #'      function ymap(st)',
     #'c Use this function to interpolate by means of',
     #'c   stnode_i=ymap(stnode_stored_i).',
     #'c Example (to be used below): tmp=log10(st)',
     #'      implicit none',
     #'      real*8 ymap,st,tmp',
     #'c',
     #'      tmp=st',
     #'      ymap=tmp',
     #'      return',
     #'      end',
     #'  ',
     #'  ',
     #'      function zmap(xm)',
     #'c Use this function to interpolate by means of',
     #'c   xmnode_i=zmap(xmnode_stored_i).',
     #'c Example (to be used below): tmp=log10(xm)',
     #'      implicit none',
     #'      real*8 zmap,xm,tmp',
     #'c',
     #'      tmp=xm',
     #'      zmap=tmp',
     #'      return',
     #'      end'
c
        end program


      DOUBLE PRECISION FUNCTION DT_EBIND(Ia,Iz)

C***********************************************************************
C Binding energy for nuclei.                                           *
C (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
C                 IA        mass number                                *
C                 IZ        atomic number                              *
C This version dated 5.5.95   is updated by S. Roesler.                *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION a1 , a2 , a3 , a4 , a5 , aa , ZERO
      INTEGER Ia , ia5 , Iz
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0)

      DATA a1 , a2 , a3 , a4 , a5/0.01575D0 , 0.0178D0 , 0.000710D0 ,
     &     0.0237D0 , 0.034D0/

      IF ( (Ia.LE.1) .OR. (Iz.EQ.0) ) THEN

         IF ( LPRi.GT.4 ) WRITE (LOUt,'(1X,A,2I5)')
     &         'DT_EBIND IA,IZ set EBIND=0.  ' , Ia , Iz
         DT_EBIND = ZERO
         RETURN
      END IF
      aa = Ia
      DT_EBIND = a1*aa - a2*aa**0.666667D0 - a3*Iz*Iz*aa**(-0.333333D0)
     &           - a4*(Ia-2*Iz)**2/aa
      IF ( MOD(Ia,2).EQ.1 ) THEN
         ia5 = 0
      ELSE IF ( MOD(Iz,2).EQ.1 ) THEN
         ia5 = 1
      ELSE
         ia5 = -1
      END IF
      DT_EBIND = DT_EBIND - ia5*a5*aa**(-0.75D0)

      END FUNCTION


      SUBROUTINE DIPOLE(BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
C
C DIPOLE COMPUTES THE MAGNETIC INTENSITY AT THE POINT (XX,YY,ZZ) DUE
C TO A MAGNETIC DIPOLE MOMENT DEFINED ON AN MDIPOLE CARD STORED IN BUF.
C THE FORMULATION COMES FROM DARRELL NIXONS REPORT 27-23 MARCH 1972
C
      REAL MX,MY,MZ,MIN,MAX,MXA,MYB,MZC
      DIMENSION  BUF(50),IBUF(50)
      DATA FPI/12.566371/
C
      HC1=0.
      HC2=0.
      HC3=0.
C
C ICID IS 0 FOR NOW AND WILL NOT BE USED. COORDS. AND MOMENT
C ARE ASSUMED TO BE IN BASIC COORDS
C
      ICID=IBUF(1)
C
C COORDS OF POINT DIPOLE
C
      CX=BUF(2)
      CY=BUF(3)
      CZ=BUF(4)
      MX=BUF(5)
      MY=BUF(6)
      MZ=BUF(7)
      MIN=BUF(8)
      MAX=BUF(9)
C
C H WILL BE COMPUTED ONLY IF DISTANCE FROM (CX,CY,CZ) TO (XX,YY,ZZ) IS
C BETWEEN MIN AND MAX- IF MAX IS 0, COMPUTE FOR ALL POINTS GREATER THAN
C MIN
C
      RMR1=SQRT((XX-CX)**2+(YY-CY)**2+(ZZ-CZ)**2)
      IF(MIN.LE.1.E-6)GO TO 5
      IF(RMR1.LT.MIN)GO TO 20
    5 IF(MAX.LE.1.E-6)GO TO 10
      IF(RMR1.GT.MAX)GO TO 20
C
   10 MXA=3.*MX*(XX-CX)
      MYB=3.*MY*(YY-CY)
      MZC=3.*MZ*(ZZ-CZ)
C
      R3=RMR1**3
      R5=R3*RMR1**2
      XNUM=(MXA+MYB+MZC)/R5
C
      HC1=-MX/R3+XNUM*(XX-CX)
      HC1=HC1/FPI
C
      HC2=-MY/R3+XNUM*(YY-CY)
      HC2=HC2/FPI
C
      HC3=-MZ/R3+XNUM*(ZZ-CZ)
      HC3=HC3/FPI
C
   20 RETURN
      END


!
!     Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
!
! NVIDIA CORPORATION and its licensors retain all intellectual property
! and proprietary rights in and to this software, related documentation
! and any modifications thereto.  Any use, reproduction, disclosure or
! distribution of this software and related documentation without an express
! license agreement from NVIDIA CORPORATION is strictly prohibited.
!

!
! Jacobi iteration example using OpenACC Directives in Fortran
! Build with
!   pgfortran -acc -Minfo=accel -fast f3.f90
!
module sm
contains
 subroutine smooth( a, b, w0, w1, w2, n, m, niters )
  real, dimension(:,:) :: a,b
  real :: w0, w1, w2
  integer :: n, m, niters
  integer :: i, j, iter
  !$acc data copy(a(:,:)) copyin(b(:,:))
   do iter = 1,niters
    !$acc kernels loop
    do i = 2,n-1
     do j = 2,m-1
      a(i,j) = w0 * b(i,j) + &
               w1 * (b(i-1,j) + b(i,j-1) + b(i+1,j) + b(i,j+1)) + &
               w2 * (b(i-1,j-1) + b(i-1,j+1) + b(i+1,j-1) + b(i+1,j+1))
     enddo
    enddo
    !$acc kernels loop
    do i = 2,n-1
     do j = 2,m-1
      b(i,j) = w0 * a(i,j) + &
               w1 * (a(i-1,j) + a(i,j-1) + a(i+1,j) + a(i,j+1)) + &
               w2 * (a(i-1,j-1) + a(i-1,j+1) + a(i+1,j-1) + a(i+1,j+1))
     enddo
    enddo
   enddo
  !$acc end data
 end subroutine
 subroutine smoothhost( a, b, w0, w1, w2, n, m, niters )
  real, dimension(:,:) :: a,b
  real :: w0, w1, w2
  integer :: n, m, niters
  integer :: i, j, iter
   do iter = 1,niters
    do i = 2,n-1
     do j = 2,m-1
      a(i,j) = w0 * b(i,j) + &
               w1 * (b(i-1,j) + b(i,j-1) + b(i+1,j) + b(i,j+1)) + &
               w2 * (b(i-1,j-1) + b(i-1,j+1) + b(i+1,j-1) + b(i+1,j+1))
     enddo
    enddo
    do i = 2,n-1
     do j = 2,m-1
      b(i,j) = w0 * a(i,j) + &
               w1 * (a(i-1,j) + a(i,j-1) + a(i+1,j) + a(i,j+1)) + &
               w2 * (a(i-1,j-1) + a(i-1,j+1) + a(i+1,j-1) + a(i+1,j+1))
     enddo
    enddo
   enddo
 end subroutine
end module

program main
 use sm
 use openacc
 real,dimension(:,:),allocatable :: aa, bb
 real,dimension(:,:),allocatable :: aahost, bbhost
 real :: w0, w1, w2
 integer :: i,j,n,m,iters
 integer :: c0, c1, c2, c3, cgpu, chost
 integer :: errs, args
 character(10) :: arg
 real :: dif, tol

 n = 0
 m = 0
 iters = 0
 args = command_argument_count()
 if( args .gt. 0 )then
   call get_command_argument( 1, arg )
   read(arg,'(i10)') n
   if( args .gt. 1 )then
    call get_command_argument( 2, arg )
    read(arg,'(i10)') m
    if( args .gt. 2 )then
     call get_command_argument( 3, arg )
     read(arg,'(i10)') iters
     if( args .gt. 3 )then
      call get_command_argument( 4, arg )
      if( arg .eq. 'host' .or. arg .eq. 'HOST' )then
       call acc_set_device( acc_device_host )
       print *, 'set host'
      else if( arg .eq. 'nvidia' .or. arg .eq. 'NVIDIA' )then
       call acc_set_device( acc_device_nvidia )
       call acc_init( acc_device_nvidia )
       print *, 'initialize nvidia'
      else
       print *, 'unknown device:', arg
       print *, 'using default'
      endif
     endif
    endif
   endif
 endif
 if( n .le. 0 ) n = 1000
 if( m .le. 0 ) m = n
 if( iters .le. 0 ) iters = 10

 allocate( aa(n,m) )
 allocate( bb(n,m) )
 allocate( aahost(n,m) )
 allocate( bbhost(n,m) )
 do i = 1,n
   do j = 1,m
     aa(i,j) = 0
     bb(i,j) = i*1000 + j
     aahost(i,j) = 0
     bbhost(i,j) = i*1000 + j
   enddo
 enddo
 w0 = 0.5
 w1 = 0.3
 w2 = 0.2
 call system_clock( count=c1 )
 call smooth( aa, bb, w0, w1, w2, n, m, iters )
 call system_clock( count=c2 )
 cgpu = c2 - c1
 call smoothhost( aahost, bbhost, w0, w1, w2, n, m, iters )
 call system_clock( count=c3)
 chost = c3 - c2
 ! check the results
 errs = 0
 tol = 0.000005
 do i = 1,n
  do j = 1,m
   dif = abs(aa(i,j) - aahost(i,j))
   if( aahost(i,j) .ne. 0 ) dif = abs(dif/aahost(i,j))
   if( dif .gt. tol )then
    errs = errs + 1
    if( errs .le. 10 )then
     print *, i, j, aa(i,j), aahost(i,j)
    endif
   endif
  enddo
 enddo
 print *, cgpu, ' microseconds on GPU'
 print *, chost, ' microseconds on host'
 if (errs .ne. 0) then
    print *, "Test FAILED"
    print *, errs, ' errors found'
 else
    print *, "Test PASSED"
 endif

end program


PROGRAM bad_nested_loops_1
INTEGER :: i, j, product
DO i = 1, 3
   DO j = 1, 3
      product = i * j
      WRITE (*,*) i, ' * ', j, ' = ', product
END DO
END PROGRAM bad_nested_loops_1


module local_routines
    !!
    !! Setup routine for "Benchmark Problem 1" from the "Third International workshop
    !! on long-wave runup models, June 17-18 2004". It models the runup of an initial
    !! waveform on a linearly sloping beach. The analytical solution was produced
    !! using the techniques of Carrier, Wu and Yeh (2003). The problem descriptions
    !! and solution were sourced from http://isec.nacse.org/workshop/2004\_cornell/bmark1.html
    !!
    use global_mod, only: dp, ip, charlen, wall_elevation
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use linear_interpolator_mod, only: linear_interpolator_type

    implicit none

    contains

    subroutine set_initial_conditions(domain, wall_width)
        class(domain_type), target, intent(inout):: domain
        real(dp), intent(in) :: wall_width

        integer(ip):: i, j, initial_stage_unit, file_header_lines
        character(len=charlen):: initial_stage
        real(dp), allocatable:: x(:)
        real(dp) :: wall
        real(dp) :: gauge_xy(3,3)
        real(dp), parameter :: beach_slope = -1.0_dp/10.0_dp
        type(linear_interpolator_type):: initial_stage_interpolator
        integer(ip), parameter :: nb = 1001 ! Number of points in boundary series
        real(dp) :: initial_x(nb + 1), initial_s(nb + 1)

        !
        ! Read the initial stage
        !
        initial_stage = './DATA/initial_condition.txt'
        open(newunit=initial_stage_unit, file=initial_stage)
        ! Skip the file header
        file_header_lines=13
        do i = 1, file_header_lines
            read(initial_stage_unit, *)
        end do
        ! Since the file starts at x=0, lets append large negative x, so the
        ! interpolator covers the whole domain
        initial_x(1) = -1.0e+06_dp
        initial_s(1) = 0.0_dp
        do i = 2, nb+1
            read(initial_stage_unit, *) initial_x(i), initial_s(i)
        end do
        close(initial_stage_unit)
        ! Make the interpolation function
        call initial_stage_interpolator%initialise(initial_x, initial_s)

        allocate(x(domain%nx(1)))
        x = domain%x
        wall = 50.0_dp
        do j = 1, domain%nx(2)
            ! Make the topography, with side-walls of fixed width (cannot just
            ! have a single cell, because of nesting)
            if( (domain%y(j) < wall_width) .or. (domain%lw(2) - domain%y(j) < wall_width)) then
                domain%U(:,j,ELV) = wall
            else
                domain%U(:,j,ELV) = x * beach_slope
            end if
            call initial_stage_interpolator%eval(x, domain%U(:,j,STG))
        end do
        call initial_stage_interpolator%finalise

        !if(maxval(domain%x) > 49950.0_dp) then
        !    domain%U(domain%nx(1), :, ELV) = wall
        !end if
        ! Use walls as lateral boundary conditions
        ! FIXME: Use periodic boundary conditions instead
        !domain%U(domain%nx(1), :, ELV) = wall

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV) + 1.0e-07_dp)

        deallocate(x)

        print*, 'Elevation range: ', minval(domain%U(:,:,ELV)), maxval(domain%U(:,:,ELV))

        if(allocated(domain%manning_squared)) then
            domain%manning_squared = 0.0_dp**2
        end if

        if(domain%timestepping_method == 'cliffs') then
            domain%cliffs_minimum_allowed_depth = 0.02_dp
        end if

        !! Gauges
        !gauge_xy(1:3, 1) = [4.521, 1.196, 5.0]
        !gauge_xy(1:3, 2) = [4.521, 1.696, 7.0]
        !gauge_xy(1:3, 3) = [4.521, 2.196, 9.0]
        !call domain%setup_point_gauges(xy_coords = gauge_xy(1:2,:), gauge_ids=gauge_xy(3,:))

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program landslide_tsunami
    !! "Benchmark Problem 1" from the "Third International workshop
    !! on long-wave runup models, June 17-18 2004". It models the runup of an initial
    !! waveform on a linearly sloping beach. The analytical solution was produced
    !! using the techniques of Carrier, Wu and Yeh (2003). The problem descriptions
    !! and solution were sourced from http://isec.nacse.org/workshop/2004\_cornell/bmark1.html

    use global_mod, only: ip, dp, minimum_allowed_depth, default_nonlinear_timestepping_method
    use domain_mod, only: domain_type
    use multidomain_mod, only: multidomain_type, setup_multidomain, test_multidomain_mod
    use boundary_mod, only: boundary_stage_transmissive_normal_momentum, flather_boundary
    use local_routines
    use timer_mod
    use logging_mod, only: log_output_unit
    implicit none

    ! nd domains in the model; j is for loops
    integer(ip):: nd, j

    ! Type holding all domains
    type(multidomain_type) :: md

    type(timer_type) :: program_timer

    real(dp), parameter :: mesh_refine = 1.0_dp ! Increase/decrease resolution by this amount

    real(dp) ::  global_dt != 0.040_dp / mesh_refine

    ! Approx timestep between outputs
    real(dp) :: approximate_writeout_frequency = 1.00_dp
    real(dp) :: final_time = 360.0_dp

    ! Length/width
    real(dp), parameter :: global_lw(2) = [400.0_dp + 50000.0_dp, 125.0_dp/mesh_refine]
    ! Lower-left corner coordinate
    real(dp), parameter :: global_ll(2) = [-400.0_dp, 0.0_dp]
    ! grid size (number of x/y cells)
    !integer(ip), dimension(2):: global_nx = [nint(global_lw(1)/25.0_dp)*nint(mesh_refine), 5_ip] !nint(global_lw/25.0_dp) * mesh_refine

    real(dp) :: res_d1 = 25.0_dp/mesh_refine, res_d2 = 5.0_dp/mesh_refine

    call program_timer%timer_start('setup')

    ! nd domains in this model
    nd = 2
    allocate(md%domains(nd))

    !
    ! Setup basic metadata
    !

    ! Main domain
    md%domains(1)%lower_left = global_ll  + [3000.0_dp, 0.0_dp] !global_ll
    md%domains(1)%lw = global_lw - [3000.0_dp, 0.0_dp]
    md%domains(1)%nx = nint(md%domains(1)%lw/res_d1)
    md%domains(1)%dx = md%domains(1)%lw/md%domains(1)%nx
    md%domains(1)%timestepping_refinement_factor = 1_ip
    md%domains(1)%dx_refinement_factor = 1.0_dp
    md%domains(1)%timestepping_method = default_nonlinear_timestepping_method ! Can set this to 'linear', but the difference with the analytical solution becomes obvious

    !print*, 1, ' lw: ', md%domains(1)%lw, ' ll: ', md%domains(1)%lower_left, ' dx: ', md%domains(1)%dx, &
    !    ' nx: ', md%domains(1)%nx

    ! Main domain
    md%domains(2)%lower_left = global_ll
    md%domains(2)%lw = global_lw - [md%domains(1)%lw(1), 0.0_dp]
    md%domains(2)%nx = nint(md%domains(2)%lw/res_d2)
    md%domains(2)%dx = md%domains(2)%lw/md%domains(2)%nx
    md%domains(2)%timestepping_refinement_factor = 1_ip
    md%domains(2)%dx_refinement_factor = res_d1/res_d2
    md%domains(2)%timestepping_method = default_nonlinear_timestepping_method !'cliffs'

    ! Allocate domains and prepare comms
    call md%setup()

    ! Initial conditions
    do j = 1, size(md%domains)
        call set_initial_conditions(md%domains(j), wall_width=res_d1*2)
    end do
    call md%make_initial_conditions_consistent()

    md%domains(1)%boundary_subroutine => flather_boundary !boundary_subroutine

    ! NOTE: For stability in 'null' regions, we set them to 'high land' that
    ! should be inactive.
    call md%set_null_regions_to_dry()

    print*, 'End setup'

    ! Print the gravity-wave CFL limit, to guide timestepping
    do j = 1, size(md%domains)
        print*, 'domain: ', j, 'ts: ', &
            md%domains(j)%stationary_timestep_max()
    end do

    global_dt = md%stationary_timestep_max()
    ! rk2n needs a shorter timestep
    if(md%domains(1)%timestepping_method == 'rk2n') global_dt = global_dt * 0.8_dp

    call program_timer%timer_end('setup')
    call program_timer%timer_start('evolve')

    ! Evolve the code
    do while (.true.)

        ! IO
        call program_timer%timer_start('IO')
        call md%write_outputs_and_print_statistics(approximate_writeout_frequency=approximate_writeout_frequency)
        call program_timer%timer_end('IO')

        if (md%domains(1)%time > final_time) exit
        call md%evolve_one_step(global_dt)

    end do

    call program_timer%timer_end('evolve')
    call md%finalise_and_print_timers

    print*, ''
    call program_timer%print(output_file_unit=log_output_unit)

end program


** 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

*   Double complex arithmetic operations (+, -, *, /), including constant
*   folding and implied type conversions to double complex.

	implicit double complex (c, p)
	parameter(n = 35)
	double complex rslts(n), expect(n)
	integer*8 iexpect(12), iex2(4)
	equivalence (iexpect, expect(19)), (iex2, expect(33))

	common c35, c2462, c79

	parameter(p1 = - (1, 2))
	parameter(p2 = (1, 2) + (2.0, 3))
	parameter(p3 = (1.0, 1.0) - (-5.0))
	parameter(p4 = (-2, 3) * (4, 5))
	parameter(p5 = (4, 6) / 2 )

	data i12, i4 / 12, 4 /
	data x6      / 6.0   /
	data c12, cn46 / (1, 2), (-4.0, 6) /

c --- tests 1 - 12:  addition:

	data (expect(i), i = 1, 6) / (-4, 6), (11, -2), (9, -8),
     +                               (-3, 8), (13, 2), (14, 8)   /

	rslts(1) =  (1.0, -2.0) + (-5.0, 8.0)
	rslts(2) = (1.0, -2.0) + 10
	rslts(3) = dcmplx(8, -9) + (1, 1)
	rslts(4) = c12 + cn46
	rslts(5) = i12 + c12
	rslts(6) = c12*4 + 10.0

c --- tests 13 - 24:  subtraction:

	data (expect(i), i = 7, 12) / (-6, 10), (9, -2), (-6, -8),
     +                                (-20, 16), (-5, 2), (2, -8) /

	rslts(7) = (-5.0, 8.0) - (1.0, -2.0)
	rslts(8) = 10.0d0 - (1.0, 2.0)
	rslts(9) = (2, -2) - dcmplx(8.0, x6)
	rslts(10) = (cn46 - c12) * i4
	rslts(11) = c12 - x6
	rslts(12) = x6 - (i4 * c12)

c --- tests 25 - 36:  multiplication:

	data (expect(i), i = 13, 18) / (26, 51), (10, 15), (-14, 22),
     +                                 (-16, -2), (-4, 6), (30, 12)  /

	rslts(13) = (2.0, -5.0) * (-7.0, 8.0)
	rslts(14) = (-2, -3) * (-5)
	rslts(15) = dcmplx(x6, 2.0) * dcmplx(-1, i4)
	rslts(16) = c12 * cn46
	rslts(17) = (1, 0) * cn46
	rslts(18) = (i4 + c12) * x6

c --- tests 37 - 48:  division:

	data iexpect / 1, -3,   3, -6,    3, -3,
     +                 1, -3,   3, 4,     1, -3  /

	data c973/(.9, 7.3)/,  c6181/(6.1, 8.1)/,  c2n1/(2,-1)/

	call ctoi(rslts(19), (.9d0, 7.3d0) / (-2d0, 1.0d0))
	call ctoi(rslts(20), (6.1d0, -12.1d0) / 2d0)
	call ctoi(rslts(21), (6.1d0) / (1d0, 1d0))
	call ctoi(rslts(22), c973 / (-2d0, 1.0d0))
	call ctoi(rslts(23), c6181 / (x6 - 4.0d0) )
	call ctoi(rslts(24), c973 / (-c2n1) )

c --- tests 49 - 54:  unary minus:

	data (expect(i), i = 25, 27) / (-1, -2), (-2, 1), (14, 4) /

	rslts(25) = - (1.0, 2.0)
	rslts(26) = - c2n1
	rslts(27) = 2.0 * (-(-(c12 + x6)))

c --- tests 55 - 64:  double complex parameters:

	data (expect(i), i=28, 32) / (-1, -2), (3, 5), (6, 1),
     +                               (-23, 2), (2, 3)         /

	rslts(28) = p1
	rslts(29) = p2
	rslts(30) = p3
	rslts(31) = p4
	rslts(32) = dcmplx(nint(real(p5)), nint(aimag(p5)) )

c --- tests 65 - 70:  double complex multiplication/division bugs:

	data iex2 / 7, 9, 3, 5 /, expect(35) / (-11, 23) /
	data c35, c79, c2462 / (3, 5), (7, 9), (-24, 62) /

	c35 = c2462 / c35
	call ctoi(rslts(33), c35)
	c2462 = c2462 / c79
	call ctoi(rslts(34), c2462)
        c79 = c79 * c12
        rslts(35) = c79

c --- check results:

	call check(rslts, expect,  4*n)
	end

cccccccccccccc

	subroutine ctoi(ia, c)
	double complex c
	integer*8 ia(2)
	ia(1) = real(c) + .001
	ia(2) = aimag(c) + .001
	end


	subroutine splines(x,y,no,ntau,tau,yy,f)

	include 'PARAMETER'   !por kt
	parameter (kt2=kt*kn)
	implicit real*4 (a-h,o-z)
	real*4 a(kt,kt),x(*),y(*),tau(*),yy(*),f(kt,kt),ff(kt2)
	real*4 taure(kt)
	COMMON/FACTORSPLIN/FF
 	common/cambio/ncambno,ncambpre  !si 0,0 cambio nodos, cambio prec
c ncambno vale 0 la primera vez que se corre un ciclo
c      "       "   1 las restantes
	data iset/0/

 	iset=iset*ncambno

	n=no+2
	IF(ISET.EQ.0)THEN
           paso=x(2)-x(1)
	   iset=1
 	   ncambno=1
	   if(n.gt.2)then
	      CALL SPLINB(n,kt,a)

	      ks=0
	      do i=1,ntau
                j1=1+int((tau(i)-x(1))/paso)
	        j2=j1+1
	        f2=(tau(i)-x(j1))/paso
	        f1=1.d0-f2
	        f3=f1*(f1*f1-1.d0)
	        f4=f2*(f2*f2-1.d0)
	        do k=1,n
	           f(i,k)=f3*a(j1,k)+f4*a(j2,k)
	           if(k.eq.j1)f(i,k)=f(i,k)+f1
	           if(k.eq.j2)f(i,k)=f(i,k)+f2
	        end do
	        do k=1,n
	           ks=ks+1
	           ff(ks)=f(i,k)
	        end do
	     end do
	   else
	      do i=1,ntau
	         taure(i)=(tau(i)-x(1))/paso
	      end do
	      if(no.eq.0)then
	          ks=0
	          do i=1,ntau
	             f(i,1)=1.d0-taure(i)
	             f(i,2)=taure(i)
	             do k=1,n
		        ks=ks+1
                        ff(ks)=f(i,k)
	             end do
	           end do
	       else
	       ks=0
               do i=1,ntau
 	          if(taure(i).lt.1.d0)then
			f(i,1)=1.d0-taure(i)
			f(i,2)=taure(i)
			f(i,3)=0.d0
	           else
			f(i,1)=0.d0
			f(i,2)=2.d0-taure(i)
			f(i,3)=taure(i)-1.d0
		   end if
		   do k=1,n
		      ks=ks+1
		      ff(ks)=f(i,k)
		   end do
		end do
	      end if
	    end if
	END IF

c a partir de aqui lo hace siempre

	ks=0
	do i=1,ntau
	   yy(i)=0.d0
	   do k=1,n
	      ks=ks+1
	      f(i,k)=ff(ks)
	      yy(i)=yy(i)+ff(ks)*y(k)
	   end do
	end do

	return
	end


! { dg-do run }
! PR35962 Implement F2003 rounding modes.
! Test case prepared by Jerry Delisle  <jvdelisle@gcc.gnu.org>
integer,parameter :: j = max(4, selected_real_kind (precision (0.0_4) + 1))
integer,parameter :: k = max(4, selected_real_kind (precision (0.0_8) + 1))
character(64) :: line
  write(line, '(RN, 4F10.3)') 0.0625_j, 0.1875_j
  if (line.ne."     0.062     0.188") STOP 1
  write(line, '(RN, 4F10.2)') 0.125_j, 0.375_j, 1.125_j, 1.375_j
  if (line.ne."      0.12      0.38      1.12      1.38") STOP 2
  write(line, '(RN, 4F10.1)') 0.25_j, 0.75_j, 1.25_j, 1.75_j
  if (line.ne."       0.2       0.8       1.2       1.8") STOP 3
  write(line, '(RN, 4F10.0)') 0.5_j, 1.5_j, 2.5_j, 3.5_j
  if (line.ne."        0.        2.        2.        4.") STOP 4

  write(line, '(RN, 4F10.3)') 0.0625_k, 0.1875_k
  if (line.ne."     0.062     0.188") STOP 5
  write(line, '(RN, 4F10.2)') 0.125_k, 0.375_k, 1.125_k, 1.375_k
  if (line.ne."      0.12      0.38      1.12      1.38") STOP 6
  write(line, '(RN, 4F10.1)') 0.25_k, 0.75_k, 1.25_k, 1.75_k
  if (line.ne."       0.2       0.8       1.2       1.8") STOP 7
  write(line, '(RN, 4F10.0)') 0.5_k, 1.5_k, 2.5_k, 3.5_k
  if (line.ne."        0.        2.        2.        4.") STOP 8
end


! =====================================================================
! program ITPPRP
!
! This program finds the ground state wavefunction of the
! time-independent Gross-Pitaevskii equation in a polar coordinate
! system using imaginary time propagation. ITPPRP is a modified version
! of NLSPRP written to propagate in imaginary time. All modified
! functions and/or subroutines required for this task are given below.
! All other functions and/or subroutines used by ITPPRP are listed with
! NLSPRP.
! ---------------------------------------------------------------------
      program ITPPRP
      implicit none

      double precision, parameter :: pi = 3.14159265358979323846d0

      integer :: nT
      integer :: nTskp
      integer :: nR
      integer :: nP
      integer :: qnR
      integer :: qmL
      double precision :: Ta
      double precision :: Tb
      double precision :: Ra
      double precision :: Rb
      double precision :: Ro
      double precision :: kR
      double precision :: Po
      double precision :: kP
      double precision :: Xo
      double precision :: kX
      double precision :: Yo
      double precision :: kY
      double precision :: g2

      integer :: i, j, k, m
      integer :: nRP
      integer :: nS
      integer :: nFile
      integer :: nInfo
      double precision :: T
      double precision :: dT
      double precision :: dR
      double precision :: dP
      double precision :: dRP

      double precision, allocatable :: R(:)
      double precision, allocatable :: RH(:)
      double precision, allocatable :: P(:)
      double precision, allocatable :: RdRP(:)
      double precision, allocatable :: TRL(:)
      double precision, allocatable :: TRD(:)
      double precision, allocatable :: TRU(:)
      double precision, allocatable :: TPD(:)
      double precision, allocatable :: TPO(:)
      double precision, allocatable :: V(:)
      double precision, allocatable :: VT(:)
      double precision, allocatable :: VS(:)
      double precision, allocatable :: X(:)
      double complex, allocatable :: U(:)
      double complex, allocatable :: UT(:)
      double complex, allocatable :: US(:)
      double complex, allocatable :: UR(:)
      double complex, allocatable :: DL(:)
      double complex, allocatable :: D(:)
      double complex, allocatable :: DU(:)
      double complex, allocatable :: W(:)
      double complex, allocatable :: Z(:)

      double precision :: NRM
      double precision :: RXV
      double precision :: R2XV
      double precision :: PXV
      double precision :: P2XV
      double precision :: KRXV
      double precision :: KR2XV
      double precision :: KPXV
      double precision :: KP2XV
      double precision :: TRXV
      double precision :: TPXV
      double precision :: VXV

      read(5,*) nT, nTskp
      read(5,*) nR, nP
      read(5,*) Ta, Tb
      read(5,*) Ra, Rb
      read(5,*) Ro, kR
      read(5,*) Po, kP
      read(5,*) Xo, kX
      read(5,*) Yo, kY
      read(5,*) g2
      read(5,*) qnR, qmL

      nRP = nR*nP
      if (nR.ge.nP) then
         nS = nR
      else
         nS = nP
      endif
      nFile = 999
      nInfo = 0
      Po = 2.0d0*pi*Po
      T = 0.0d0
      dT = (Tb-Ta)/dfloat(nT)
      dR = (Rb-Ra)/dfloat(nR)
      dP = 2.0d0*pi/dfloat(nP)
      dRP = dR*dP

      allocate(R(nR),RH(nR+1),P(nP),RdRP(nR),TRL(nR-1),TRD(nR),TRU(nR-1))
      allocate(TPD(nR),TPO(nR),V(nRP),VT(nRP),VS(nS),X(15))
      allocate(U(nRP),UT(nRP),US(nS),UR(nP),DL(nS-1),D(nS),DU(nS))
      allocate(W(nP),Z(nP))

      call GRDR(nR,rA,rB,dR,R,RH)
      call GRDP(nP,dP,P)
      call MKRdRP(nR,dRP,R,RdRP)
      call MKTR(nR,dR,R,RH,TRL,TRD,TRU)
      call MKTP(nR,dP,R,TPD,TPO)

      call USHO(nRP,nR,nP,Xo,Yo,kX,kY,R,P,U)
      !call USHOR(nRP,nR,nP,Ro,kR,R,P,U)
      !call USHO2(nRP,nR,nP,qnR,qmL,kR,R,P,U)
      call NRML(nRP,nR,nP,RdRP,U)

      do i = 1, nT
         T = dfloat(i-1)*dT
         if (mod(i-1,nTskp).eq.0) then
            X(1) = NRM(nRP,nR,nP,RdRP,U)
            X(2) = RXV(nRP,nR,nP,R,RdRP,U)
            X(3) = R2XV(nRP,nR,nP,R,RdRP,U)
            X(4) = PXV(nRP,nR,nP,P,RdRP,U)
            X(5) = P2XV(nRP,nR,nP,P,RdRP,U)
            X(6) = KRXV(nRP,nR,nP,dR,R,RdRP,U)
            X(7) = KR2XV(nRP,nR,nP,dR,R,RdRP,U)
            X(10) = TRXV(nRP,nR,nP,RdRP,TRL,TRD,TRU,U)
            call ZSWP(nRP,nR,nP,U,UT)
            X(8) = KPXV(nRP,nR,nP,dP,RdRP,U)
            X(9) = KP2XV(nRP,nR,nP,dP,RdRP,U)
            X(11) = TPXV(nRP,nR,nP,RdRP,TPD,TPO,U)
            call ZSWP(nRP,nP,nR,U,UT)
            !call VAHO(nRP,nR,nP,Ro,Po,kR,kP,R,P,VT)
            call VSHO(nRP,nR,nP,Xo,Yo,kX,kY,R,P,VT)
            !call VSHOR(nRP,nR,nP,Ro,kR,R,VT)
            X(12) = VXV(nRP,nR,nP,RdRP,VT,U)
            call VNL(nRP,g2,VT,U)
            X(14) = VXV(nRP,nR,nP,RdRP,VT,U)
            X(15) = X(10) + X(11) + X(12) + X(14)
            write(900,*) T, X(1), X(2), X(3), X(4), X(5), X(6), X(7),&
               & X(8), X(9), X(10), X(11), X(12), X(13), X(14), X(15)
            call WRTUU(nFile,nRP,nR,nP,R,P,U)
            nFile = nFile + 1
         endif
         !call VAHO(nRP,nR,nP,Ro,Po,kR,kP,R,P,VT)
         call VSHO(nRP,nR,nP,Xo,Yo,kX,kY,R,P,VT)
         !call VSHOR(nRP,nR,nP,Ro,kR,R,VT)
         V = VT
         call VNL(nRP,g2,VT,U)
         V = V + VT
         call RHSR(nRP,nR,nP,dT,TRL,TRD,TRU,V,U,UT)
         call DSWP(nRP,nR,nP,V,VT)
         call ZSWP(nRP,nR,nP,U,UT)
         do j = 1, nR
            m = (j-1)*nP
            do k = 1, nP
               VS(k) = V(m+k)
               US(k) = U(m+k)
            enddo
            call LHSP(nP,dT,TPD(j),TPO(j),VS,DL,D,DU)
            call ZGTSV(nP,1,DL,D,DU,US,nP,nInfo)
            call LHSP(nP,dT,TPD(j),TPO(j),VS,DL,D,DU)
            call WZ(nP,dT,TPO(j),W,Z)
            call ZGTSV(nP,1,DL,D,DU,W,nP,nInfo)
            call SM(nP,W,Z,US)
            do k = 1, nP
               U(m+k) = US(k)
            enddo
         enddo
         call RHSP(nRP,nR,nP,dT,TPD,TPO,V,U,UT)
         call DSWP(nRP,nP,nR,V,VT)
         call ZSWP(nRP,nP,nR,U,UT)
         do j = 1, nP
            m = (j-1)*nR
            do k = 1, nR
               VS(k) = V(m+k)
               US(k) = U(m+k)
            enddo
            call LHSR(nR,dT,TRL,TRD,TRU,VS,DL,D,DU)
            call ZGTSV(nR,1,DL,D,DU,US,nR,nInfo)
            do k = 1, nR
               U(m+k) = US(k)
            enddo
         enddo
         call NRML(nRP,nR,nP,RdRP,U)
      enddo

      call WRTU(999,nRP,nR,nP,R,P,U)
      call WRTUU(1999,nRP,nR,nP,R,P,U)

900   format(1X,16(F23.15))

      deallocate(R,RH,P,RdRP,TRL,TRD,TRU,TPD,TPO,V,VT,VS,X)
      deallocate(U,UT,US,UR,DL,D,DU,W,Z)

      stop
      end
! =====================================================================


c----------------------------------------------------------
c tapering both end of input seismogram
c----------------------------------------------------------
      subroutine taper(nb,ne,n,seis,ntapb,ntape,ss,ncorr)
      implicit none
      integer*4 nb,ne,n,ntapb,ntape,ncorr
      real*4    seis(32768)
      real*8    s(32768)
      double complex ss(32768)
      real*8    omb,ome,sums,c,r,pi
      integer*4 k,ns

      n = n
      pi = datan(1.0d0)*4.0d0
      omb = pi/ntapb
      ome = pi/ntape
      ncorr = ne+ntape
cxx   s = seis(1:ncorr)
c make copy seis to s
      do k = 1,ncorr
        s(k) = seis(k)
      enddo
      if(nb-ntapb-1 .gt. 0) then
          do k=1,nb-ntapb-1
              s(k) = 0.0d0
          enddo
      endif
      sums = 0.0d0
c left end of the signal
      do k = nb,nb-ntapb,-1
          r = (dcos(omb*(nb-k))+1.0d0)/2.0d0
          sums = sums + 2.0d0*r
          s(k) = s(k)*r
      enddo
c right end of the signal
      do k = ne,ne+ntape
          s(k) = s(k)*(dcos(ome*(ne-k))+1.0d0)/2.0d0
      enddo
      sums = sums+ne-nb-1
      c = 0.0d0
      do k = 1,ncorr
        c = c + s(k)
      enddo
      c = -c/sums
c left end of the signal
      do k = nb,nb-ntapb,-1
          r = (dcos(omb*(nb-k))+1.0d0)/2.0d0
          s(k) = s(k)+r*c
      enddo
c right end of the signal
      do k = ne,ne+ntape
          r = (dcos(ome*(ne-k))+1.0d0)/2.0d0
          s(k) = s(k)+r*c
      enddo
c middle of the signal
      do k = nb+1,ne-1
          s(k) = s(k)+c
      enddo
c determin the power of FFT
      ns = 2**(min0(max0(int(dlog(dble(ncorr))/dlog(2.0d0))+1,12),15))
      if(ns .gt. ncorr) then
        do k = ncorr+1,ns
          s(k) = 0.0d0
        enddo
      endif
      ncorr = ns
c convert to complex
      do k =1,ns
        ss(k) = cmplx(s(k),0.0d0)
      enddo
      return
      end


!***********************************/
!	Name:格子を重心を中心とした円として近似して簡易的な接触判定を実施する関数
!	Alias:BoundarySphereMethod
!	Description:入力された2つの格子の粗い半径の和と重心間距離の大小関係を比較し，0または1を返す
!	Type:integer
!	Input:
!	Output:
!	Note:格子が接触していないとき0を，詳細な判定が必要なとき1を返す
!	Author:Akitaka Toyota
!	Date:2017.12.19
!	Update:2017.12.19
!	Other:
!***********************************/
function BoundarySphereMethod(RoughRadius1,RoughRadius2,RC1,RC2,iTimeCombination) result(iToF)
    use StructVar_Mod
!    use LoopVar_Mod
    implicit none
    double precision, intent(in) :: RoughRadius1, RoughRadius2
    type(RelativeCoordinate),intent(in) :: RC1, RC2
    integer, intent(in):: iTimeCombination
    integer :: iToF
    double precision :: GravityCenterDistance

    if(iTimeCombination == 0) then
        GravityCenterDistance = sqrt(sum((RC1%GravityCenter(2,:) - RC2%GravityCenter(2,:))**2))
    else
        GravityCenterDistance = sqrt(sum((RC1%GravityCenter(2,:) - RC2%GravityCenter(1,:))**2))
    end if

    if(GravityCenterDistance > RoughRadius1 + RoughRadius2) then !重心間距離が半径の和より大きい = 明らかに接触していない
        iToF = 0
    else
        iToF = 1
    end if
return
end function BoundarySphereMethod


c=======================================================================
c
c     subroutine KATVAR
c
c     Kato decomposition of a symmetric matrix, maximum Kato sensibility
c     and number factors for a given variance level
c
c-----------------------------------------------------------------------
      SUBROUTINE katvar ( n, X, vargiv, epsin, indpca,
     &                    iwork, dwork,
     &                    varopt, nbfact, epsout, soreig, vpmat,
     &                    nbkgrp, grpkat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : input matrix (n*n)                          double
c            vargiv : given variance (0.0 =< vargiv = <1.0)       double
c            epsin  : input Kato-sensitivity                      double
c            indpca : indicator (21, 22, 23)                     integer
c
c     WORKSPACE
c            iwork  : vector (12*n)                              integer
c            dwork  : matrix ( n*(2*n + 27) )                     double
c
c     OUTPUT
c            varopt : optimal variance                            double
c            nbfact : number of factors                          integer
c            epsout : maximum Kato sensibility                    double
c            soreig : sorted eigenvalues (n)                      double
c            vpmat  : ordered eigenvectors (n*n)                  double
c            nbkgrp : number of Kato groups                      integer
c            grpkat : Kato groups (n) output size (nbkgrp)       integer
c            info   : diagnostic argument                        integer
c
c     CALL
c           SCHURSO : SCHUR decomposition of a symmetric matrix
c                     sorts eigenvalues and eigenvectors (decrease order)
c           GREPS   : computes groups for a sensibility epsilon
c
c     METHOD
c            for Kato groups vector
c            for an example of eigenvalues vector ( size = 7 ) :
c            soreig = [ 5.2, 5.1, 3.5, 3.4, 3.3, 1.7 1.3 ]
c            and eps = 0.15, the routine computes
c            nbkgrp = 4
c            grpvec = [ 2, 3, 1, 1 ]
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, nbfact, nbkgrp, indpca, info
      INTEGER grpkat(*)
      DOUBLE PRECISION vargiv, epsin, epsout, varopt
      DOUBLE PRECISION X(*), soreig(*), vpmat(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, piw, pdw, peig
      DOUBLE PRECISION trace, som, EPS
      PARAMETER ( EPS = 1.E-30 )
c
c     external subroutines
      EXTERNAL schurso, greps
c
c     intrinsic functions
      INTRINSIC ABS
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw    : pointer for workspaces SCHURSO needs  (12*n)
c     pinext = piw + 12*n
c     pinext : pointer for the next iwork array
c
c     Total size of iwork array ( 12*n )
c
c     pointers for double precision work space  :dwork
c     ------------------------------------------------
      peig = 1
c     peig   : pointer for vector(n), so (n) more
      pdw = peig + n
c     pdw    : pointer for workspaces SCHURSO needs  ( n*(2*n+26) )
c
c     Total size of dwork array = ( n*(2*n + 27) )
c
c-----------------------------------------------------------------------
c
c     test if vargiv in [0, 1]
      IF ( (vargiv .LT. 0.0) .OR. (vargiv .GT. 1.0) ) THEN
         info = -2003
         RETURN
      ENDIF
c
c     Schur factorization
      CALL schurso ( n, X, iwork(piw), dwork(pdw),
     &               dwork(peig), soreig, vpmat, info )
      IF (info .LT. 0) RETURN
c
c     Trace(X)
      trace = 0.0
      DO i = 1,n
         trace = trace + soreig(i)
      ENDDO
c
c     test if |Trace(X)| < EPS
      IF ( ABS(trace) .LT. EPS ) THEN
         info = -2004
         RETURN
      ENDIF
c
c     loop until (nfact > n)
      som    = 0.0
      nbfact = 0
      varopt = - 1.0
      DO WHILE ( (varopt.LT.vargiv).and.(nbfact.LT.n) )
         nbfact = nbfact + 1
         som    = som + soreig(nbfact)
         varopt = som / trace
      ENDDO
c
c     genral case
      IF ( nbfact .LT. n ) THEN
         epsout = (soreig(nbfact)-soreig(nbfact+1))*(1.0-EPS) - EPS
      ELSE
         epsout = soreig(1) - soreig(nbfact)
      ENDIF
c
c     case Kato-sensitivity as input
      IF (indpca .EQ. 21) THEN
        epsout = epsin
      ENDIF
c
c     computes Kato groups for the Kato sensitivity
      CALL greps ( n, soreig, epsout, nbkgrp, grpkat, info )
c
      RETURN
      END


!##############################################################################
! MODULE GLOBALS
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    real*8, parameter :: Kbar = 10d0
    real*8, parameter :: Tbar = 30d0
    real*8, parameter :: alpha(2) = (/0.3d0, 0.4d0/)
    real*8, parameter :: beta(2) = (/ 0.3d0, 0.6d0/)
    real*8, parameter :: a0(2) = (/0.2d0, 0.2d0/)
    real*8, parameter :: a(2, 2) = reshape((/ 0d0, 0.3d0, 0.2d0, 0d0 /),(/2,2/))
    real*8, parameter :: ID(2, 2) = reshape((/ 1d0, 0d0, 0d0, 1d0 /),(/2,2/))
    real*8, parameter :: G = 3d0
    real*8            :: tauw = 0d0
    real*8            :: taur = 0d0
    real*8            :: tauc(2) = 0d0
    real*8            :: Ybarn, q(2), p(2), w, wn, r, rn
    real*8            :: Xd(2), Y(2), ky(2), ly(2), K(2), L(2), ell

contains

    ! function to determine market equilibrium
    function markets(x)

        use toolbox

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: markets(size(x, 1))

        ! copy producer prices and taxes
        w       = 1d0
        r       = x(1)
        tauc(1) = x(2)
        tauc(2) = tauc(1)

        ! 1. calkulate K/Y and L/Y
        ky = a0*((1d0-beta)/beta*w/r)**beta
        ly = a0*(beta/(1d0-beta)*r/w)**(1d0-beta)

        ! 2. determine producer prices
        q = w*ly+r*ky
        call lu_solve(ID-transpose(a), q)

        ! 3. consumer prices and demands
        p  = q*(1d0+tauc)
        wn = w*(1d0-tauw)
        rn = r*(1d0-taur)
        Ybarn = wn*Tbar+rn*Kbar
        Xd = alpha/p*Ybarn
        ell  = (1d0-alpha(1)-alpha(2))/wn*Ybarn

        ! 4. determine output levels
        Y(1) = Xd(1)+G
        Y(2) = Xd(2)
        call lu_solve(ID-a, Y)

        ! 5. compute K and L
        K = ky*Y
        L = ly*Y

        ! 6. check markets and budget
        markets(1) = K(1)+K(2)-Kbar
        markets(2) = q(1)*G-sum(tauc*q*Xd)-tauw*w*(Tbar-ell)-taur*r*Kbar

    end function

end module