      double precision function DERFI (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C--D replaces "?": ?ERFI, ?ERFCI, ?ERFIX, ?ERM1
c>> 1998-11-01 DERFI Krogh  Removed some equivalence for "mangle".
c>> 1996-06-18 DERFI Krogh  Changes to use .C. and C%%. J not changed.
c>> 1996-03-30 DERFI Krogh  Added external statements.
C>> 1995-11-28 DERFI Krogh  Removed multiple entries.
C>> 1995-11-03 DERFI Krogh  Removed blanks in numbers for C conversion.
C>> 1994-10-20 DERFI Krogh  Changes to use M77CON
C>> 1994-04-20 DERFI CLL Edited type stmts to make DP & SP files similar
C>> 1987-10-29 DERFI Snyder  Initial code.
c
c     For -1.0 .LT. X .LT. 1.0 calculate the inverse of the error
c     function.  That is, X = ERF(ERFI).
c
c     For 0.0 .LT. X .LT. 2.0 calculate the inverse of the
c     complementary error function.  that is, X = ERFC(ERFCI).  This
c     calculation is carried out by invoking the alternate entry *ERFCI.
c
c     If X is out of range, program execution is terminated by calling
c     the error message processor.
c
c     This subprogram uses approximations due to A. Strecok from
c     Mathematics of Computation 22, (1968) pp 144-158.
c
      external DERFIX
      double precision DERFIX
      double precision X
      double precision ARG, D(6), FSIGN, S
      integer J
c
c     *****     Parameters     *****************************************
c
c MAX...  is the position in C of the last coefficient of a Chebyshev
c         polynomial expansion.
c MIN...  is the position in C of the first coefficient of a Chebyshev
c         polynomial expansion.
c NC      is the upper dimension of the array of coefficients.
c NDELTA  is the number of coefficients of the Chebyshev polynomial
c         expansion used to approximate R(X) in the range
c         0.9975 .LT. X .LE. 1-5.0D-16
c NLAMDA  is the number of coefficients of the Chebyshev polynomial
c         expansion used to approximate R(X) in the range
c         0.8 .LT. X .LE. 0.9975.
c NMU     is the number of coefficients of the Chebyshev polynomial
c         expansion used to approximate R(X) in the range
c         5.0D-16 .GT. 1-X .GE. 1.D-300.
c NXI     is the number of coefficients of the Chebyshev polynomial
c         expansion used to approximate DERFCI(X)/X in the
c         range 0.0 .LE. X .LE. 0.8.
c
c
c     *****     External References     ********************************
c
c D1MACH   Provides the round-off level.  Used to calculate the number
c          of coefficients to retain in each Chebyshev expansion.
c DERM1    Prints an error message and stops if X .LE. -1.0 or
c          X .GE. 1.0 (ERFI) or X .LE. 0.0 or X .GE. 2.0 (ERFCI).
c LOG      Calculates the natural logarithm.
c SQRT     Calculates the square root.
c
c
c     *****     Local Variables      ***********************************
c
c ARG     If ERFI or ERFCI is being approximated by a Chebyshev
c         expansion then ARG is the argument of ERFI or the argument
c         that would be used if ERFCI(X) were computed as ERFC(1-X),
c         that is, ARG = X if ERFI is being computed, or ARG = 1-X if
c         ERFCI is being computed.  If ERFI or ERFCI is being computed
c         using the initial approximation ERFI=SQRT(-LOG((1-X)*(1+X))),
c         then ARG is that initial approximation.
c C       contains the coefficients of polynomial expansions.  They are
c         stored in C in the order DELTA(0..37), LAMDA(0..26),
c         MU(0..25), XI(0..38).
c D       are used to scale the argument of the Chebyshev polynomial
c         expansion in the range 1.D-300 .LT. 1-X .LT. 0.2.
c DELTA   are coefficients of the Chebyshev polynomial expansion of R(X)
c         for 0.9975 .LT. X .LE. 1-5.0D-16.
c FIRST   is a logical SAVE variable indicating whether it is necessary
c         to calculate the number of coefficients to use for each
c         Chebyshev expansion.
c FSIGN   is X or 1.0 - X.  It is used to remember the sign to be
c         assigned to the function value.
c I, J    are used as indices.
c IMIN    is the minimum index of a coefficient in the Chebyshev
c         polynomial expansion to be used.
c JIX     is an array containing MINXI, MAXXI, MINLAM, MAXLAM, MINDEL,
c         MAXDEL, MINMU, MAXMU in locations -1..6
c LAMDA   are coefficients of the Chebyshev polynomial expansion of R(X)
c         for 0.8 .LT. X .LE. 0.9975.
c MU      are coefficients of the Chebyshev polynomial expansion of R(X)
c         for 5.0D-16 .GT. 1-X .GE. 1.D-300.
c S2      is 2.0 * S.
c S       is the argument of the Chebyshev polynomial expansion.
c W1..W3  are adjacent elements of the recurrence used to evaluate the
c         Chebyshev polynomial expansion.
c XI      are coefficients of the Chebyshev polynomial expansion of
c         ERFC(X)/X for 0.0 .LE. X .LE. 0.8.
c
      data D /-1.548813042373261659512742D0
     2,        2.565490123147816151928163D0
     3,       -.5594576313298323225436913D0
     4,        2.287915716263357638965891D0
     5,       -9.199992358830151031278420D0
     6,        2.794990820124599493768426D0/
c
      fsign = x
      arg = abs(x)
      if (arg.lt.0.0d0 .or. arg.ge.1.0d0)then
         call derm1 ('DERFI',1,2,'Argument out of range','X',x,'.')
c     In case the error level is shifted to zero by the caller:
         derfi = 0.0d0
         return
      end if
      if (arg.eq.0.0d0) then
         derfi = 0.0d0
         return
      end if
      if (arg.le.0.8d0) then
         s = 3.125d0*arg*arg - 1.0d0
         j = -1
      else
         if (arg.le.0.9975d0) then
            j = 1
         else
            j = 3
         end if
         arg = sqrt(-log((1.0d0-arg)*(1.0d0+arg)))
         s = d(j)*arg + d(j+1)
      end if
      DERFI = sign(arg*DERFIX(s, j), fsign)
      return
      end
c
c     *****     entry ERFCI     ****************************************
c
      double precision function DERFCI(X)
c     Calculate the inverse of the complementary error function.
c
      external DERFIX
      double precision DERFIX
      double precision X
      double precision ARG, D(6), FSIGN, S
      integer J
      data D /-1.548813042373261659512742D0
     2,        2.565490123147816151928163D0
     3,       -.5594576313298323225436913D0
     4,        2.287915716263357638965891D0
     5,       -9.199992358830151031278420D0
     6,        2.794990820124599493768426D0/
c
c     Decide which approximation to use, and calculate the argument of
c     the Chebyshev polynomial expansion.
c
      if (x.le.0.0d0 .or. x.ge.2.0d0) then
         call derm1('DERFCI',1,2,'Argument out of range','X',x,'.')
c     In case the error level is shifted to zero by the caller:
         derfci = 0.0d0
      end if
      if (x.eq.1.0d0) then
         derfci = 0.0d0
         return
      end if
      fsign = 1.0d0 - x
      arg = abs(fsign)
      if (arg.le.0.8d0) then
         s = 3.125d0*arg*arg - 1.0d0
         j = -1
      else
         arg = 2.0d0 - x
         if (x.lt.1.0d0) then
            s = x
         else
            s = arg
         end if
         arg = sqrt(-log(x*arg))
         if (s.lt.5.0d-16) then
            j = 5
            s = d(5)/sqrt(arg) + d(6)
         else
            if (s.ge.0.0025d0) then
               j = 1
            else if (s.ge.5.0d-16) then
               j = 3
            end if
            s = d(j)*arg + d(j+1)
         end if
      end if
      DERFCI = sign(arg*DERFIX(s, j), fsign)
      return
      end
c
      double precision function DERFIX(S, J)
c             Subroutine where most of calculations are done.
      external D1MACH
      integer MAXDEL, MAXLAM, MAXMU, MAXXI, MINDEL, MINLAM
      integer MINMU, MINXI, NC, NDELTA, NLAMDA, NMU, NXI
      parameter (MINDEL = 0)
      parameter (NDELTA = 37)
      parameter (MAXDEL = MINDEL + NDELTA)
      parameter (MINLAM = MAXDEL + 1)
      parameter (NLAMDA = 26)
      parameter (MAXLAM = MINLAM + NLAMDA)
      parameter (MINMU = MAXLAM + 1)
      parameter (NMU = 25)
      parameter (MAXMU = MINMU + NMU)
      parameter (MINXI = MAXMU + 1)
      parameter (NXI = 38)
      parameter (MAXXI = MINXI + NXI)
      parameter (NC = MAXXI)
      double precision D1MACH
      double precision C(0:NC)
      logical FIRST
      save FIRST
      integer I, J, JIX(-1:6)
      save JIX
      integer IMIN
      double precision S, S2
      double precision W1, W2, W3
c
c     *****     Equivalence Statements     *****************************
c
c Equivalence statements connecting arrays DELTA, LAMDA, MU, XI removed
c by FTK to make "mangle" work.  All references to these arrays have
c been replaced by references to C.
c
c     *****     Data Statements     ************************************
c
c     DELTA(J), J = 0..NDELTA, then
c     LAMDA(J), J = 0..NLAMDA, then
c     MU(J), J = 0..NMU, then
c     XI(J), J = 0..NXI
c
c++ With first index 0, save data by elements if ~.C.
      data C(0) /  .9566797090204925274526373D0 /
      data C(1) / -.0231070043090649036999908D0 /
      data C(2) / -.0043742360975084077333218D0 /
      data C(3) / -.0005765034226511854809364D0 /
      data C(4) / -.0000109610223070923931242D0 /
      data C(5) /  .0000251085470246442787982D0 /
      data C(6) /  .0000105623360679477511955D0 /
      data C(7) /  .0000027544123300306391503D0 /
      data C(8) /  .0000004324844983283380689D0 /
      data C(9) /   -.0000000205303366552086916D0 /
      data C(10) / -.0000000438915366654316784D0 /
      data C(11) / -.0000000176840095080881795D0 /
      data C(12) / -.0000000039912890280463420D0 /
      data C(13) / -.0000000001869324124559212D0 /
      data C(14) /  .0000000002729227396746077D0 /
      data C(15) /  .0000000001328172131565497D0 /
      data C(16) /  .0000000000318342484482286D0 /
      data C(17) /  .0000000000016700607751926D0 /
      data C(18) / -.0000000000020364649611537D0 /
      data C(19) / -.0000000000009648468127965D0 /
      data C(20) / -.0000000000002195672778128D0 /
      data C(21) / -.0000000000000095689813014D0 /
      data C(22) /  .0000000000000137032572230D0 /
      data C(23) /  .0000000000000062538505417D0 /
      data C(24) /  .0000000000000014584615266D0 /
      data C(25) /  .0000000000000001078123993D0 /
      data C(26) / -.0000000000000000709229988D0 /
      data C(27) / -.0000000000000000391411775D0 /
      data C(28) / -.0000000000000000111659209D0 /
      data C(29) / -.0000000000000000015770366D0 /
      data C(30) /  .0000000000000000002853149D0 /
      data C(31) /  .0000000000000000002716662D0 /
      data C(32) /  .0000000000000000000957770D0 /
      data C(33) /  .0000000000000000000176835D0 /
      data C(34) / -.0000000000000000000009828D0 /
      data C(35) / -.0000000000000000000020464D0 /
      data C(36) / -.0000000000000000000008020D0 /
      data C(37) / -.0000000000000000000001650D0 /
      data C(38) /  .9121588034175537733059200D0 /
      data C(39) / -.0162662818676636958546661D0 /
      data C(40) /  .0004335564729494453650589D0 /
      data C(41) /  .0002144385700744592065205D0 /
      data C(42) /  .0000026257510757648130176D0 /
      data C(43) / -.0000030210910501037969912D0 /
      data C(44) / -.0000000124060618367572157D0 /
      data C(45) /  .0000000624066092999917380D0 /
      data C(46) / -.0000000005401247900957858D0 /
      data C(47) /   -.0000000014232078975315910D0 /
      data C(48) /  .0000000000343840281955305D0 /
      data C(49) /  .0000000000335848703900138D0 /
      data C(50) / -.0000000000014584288516512D0 /
      data C(51) / -.0000000000008102174258833D0 /
      data C(52) /  .0000000000000525324085874D0 /
      data C(53) /  .0000000000000197115408612D0 /
      data C(54) / -.0000000000000017494333828D0 /
      data C(55) / -.0000000000000004800596619D0 /
      data C(56) /  .0000000000000000557302987D0 /
      data C(57) /  .0000000000000000116326054D0 /
      data C(58) / -.0000000000000000017262489D0 /
      data C(59) / -.0000000000000000002784973D0 /
      data C(60) /  .0000000000000000000524481D0 /
      data C(61) /  .0000000000000000000065270D0 /
      data C(62) / -.0000000000000000000015707D0 /
      data C(63) / -.0000000000000000000001475D0 /
      data C(64) /  .0000000000000000000000450D0 /
      data C(65) /  .9885750640661893136460358D0 /
      data C(66) /  .0108577051845994776160281D0 /
      data C(67) / -.0017511651027627952494825D0 /
      data C(68) /  .0000211969932065633437984D0 /
      data C(69) /  .0000156648714042435087911D0 /
      data C(70) / -.0000005190416869103124261D0 /
      data C(71) / -.0000000371357897426717780D0 /
      data C(72) /  .0000000012174308662357429D0 /
      data C(73) / -.0000000001768115526613442D0 /
      data C(74) /   -.0000000000119372182556161D0 /
      data C(75) /  .0000000000003802505358299D0 /
      data C(76) / -.0000000000000660188322362D0 /
      data C(77) / -.0000000000000087917055170D0 /
      data C(78) / -.0000000000000003506869329D0 /
      data C(79) / -.0000000000000000697221497D0 /
      data C(80) / -.0000000000000000109567941D0 /
      data C(81) / -.0000000000000000011536390D0 /
      data C(82) / -.0000000000000000001326235D0 /
      data C(83) / -.0000000000000000000263938D0 /
      data C(84) /  .0000000000000000000005341D0 /
      data C(85) / -.0000000000000000000022610D0 /
      data C(86) /  .0000000000000000000009552D0 /
      data C(87) / -.0000000000000000000005250D0 /
      data C(88) /  .0000000000000000000002487D0 /
      data C(89) / -.0000000000000000000001134D0 /
      data C(90) /  .0000000000000000000000420D0 /
      data C(91) /  .9928853766189408231495800D0 /
      data C(92) /  .1204675161431044864647846D0 /
      data C(93) /  .0160781993420999447257039D0 /
      data C(94) /  .0026867044371623158279591D0 /
      data C(95) /  .0004996347302357262947170D0 /
      data C(96) /  .0000988982185991204409911D0 /
      data C(97) /  .0000203918127639944337340D0 /
      data C(98) /  .0000043272716177354218758D0 /
      data C(99) /  .0000009380814128593406758D0 /
      data C(100) /  .0000002067347208683427411D0 /
      data C(101) /  .0000000461596991054300078D0 /
      data C(102) /  .0000000104166797027146217D0 /
      data C(103) /  .0000000023715009995921222D0 /
      data C(104) /  .0000000005439284068471390D0 /
      data C(105) /  .0000000001255489864097987D0 /
      data C(106) /  .0000000000291381803663201D0 /
      data C(107) /  .0000000000067949421808797D0 /
      data C(108) /  .0000000000015912343331469D0 /
      data C(109) /  .0000000000003740250585245D0 /
      data C(110) /  .0000000000000882087762421D0 /
      data C(111) /  .0000000000000208650897725D0 /
      data C(112) /  .0000000000000049488041039D0 /
      data C(113) /  .0000000000000011766394740D0 /
      data C(114) /  .0000000000000002803855725D0 /
      data C(115) /  .0000000000000000669506638D0 /
      data C(116) /  .0000000000000000160165495D0 /
      data C(117) /  .0000000000000000038382583D0 /
      data C(118) /  .0000000000000000009212851D0 /
      data C(119) /  .0000000000000000002214615D0 /
      data C(120) /  .0000000000000000000533091D0 /
      data C(121) /  .0000000000000000000128488D0 /
      data C(122) /  .0000000000000000000031006D0 /
      data C(123) /  .0000000000000000000007491D0 /
      data C(124) /  .0000000000000000000001812D0 /
      data C(125) /  .0000000000000000000000439D0 /
      data C(126) /  .0000000000000000000000106D0 /
      data C(127) /  .0000000000000000000000026D0 /
      data C(128) /  .0000000000000000000000006D0 /
      data C(129) /  .0000000000000000000000002D0 /
c
      data FIRST /.TRUE./
c
      data JIX /MINXI, MAXXI, MINLAM, MAXLAM, MINDEL, MAXDEL
     1,         MINMU, MAXMU/
c
c     *****     Procedures     *****************************************
c
c     Decide which approximation to use, and calculate the argument of
c     the Chebyshev polynomial expansion.
c
c
c     If this is the first call, calculate the degree of each expansion.
c
      if (first) then
         first = .false.
         s2 = 0.5d0*d1mach(3)
         do 120 imin = -1, 5, 2
            do 110 i = jix(imin), jix(imin+1)
               if (abs(c(i)).lt.s2) then
                  jix(imin+1) = i
                  go to 120
               end if
110         continue
120      continue
      end if
c
c     Evaluate the Chebyshev polynomial expansion.
c
      s2 = s + s
      w1 = 0.0d0
      w2 = 0.0d0
      imin = jix(j)
      i = jix(j+1)
200      w3 = w2
         w2 = w1
         w1 = (s2*w2 - w3) + c(i)
         i = i - 1
         if (i.gt.imin) go to 200
      derfix = (s*w1 - w2) + c(imin)
      return
      end


c############################################################
c IPT solution of the Hubbard model on the real axis at T=0
c by M.J. Rozenberg
c This code is essentially the first code IPT on the real axis
c that was able to go across the Mott-Hubbard transition and
c observe the coexistent solutions. It was written by X.Y. Zhang
c and M.J. Rozenberg, and the results published in X.Y. Zhang,
c M. J. Rozenberg and G. Kotliar, Phys Rev Lett v70, p1666 (1993)
c############################################################

 	parameter(L=2*8192)
	implicit real*8(a-h,o-z)
	double complex one,xi,xs,sq,g,ome
	double complex g0(2*L),tg0(2*L),fg0(-L:L)
	double complex sft2(2*L),sf2(2*L),sft(-L:L),sf(-L:L)
	double precision dns(2*L), dns0(2*L)

c************************************************
c read input data
c f = 	frequency mesh
c d0 = 	half-bandwidth of the semicircular DOS (Bethe lattice)
c u =	Hubbard repulsion

 	read(22,*)f,d0,u
c************************************************

c************************************************
c initialize parameters
 	pi=datan(1.d0)*4.d0
	dtau=2.*pi/f/dfloat(2*L)
	f2=f**2
	one=(1.d0,0.d0)
	xi =(0.d0,1.d0)
	XL=dfloat(L)
	L2=2*L

c set the imet flag for metallic or insulating solution
 	if(u.le.3.d0)imet=1
 	if(u.gt.3.3d0)imet=0
 	if(u.gt.3.d0.and.u.le.3.3d0)then
123	continue
	write(6,*) 'find the metal or the insulator? (1 or 0)'
	read(5,*)imet
	if(imet.ne.0.and.imet.ne.1)then
	write(6,*) 'you have to type 1 for metal or 0 for insulator'
	goto 123
 	endif
 	endif

	print*,imet

c nloop= number of sc loops
	if(imet.eq.0)then
	nloop=30
	else
	nloop=10
	if(u.gt.2.d0) nloop=30
	if(u.gt.3.d0) nloop=100
	if(u.gt.3.2d0) nloop=300
	endif

c nl0= fixes the number of last sc loops to print out
c default is 1
	nl0=nloop-1

c output data parameters
	i01=20
	imax1=2000
	i02=30
	imax2=16000

	do i=-L,L
	sf(i)=(0.d0,0.d0)
	enddo

c*******************************************************

c self-consistent loop starts here**********************
	do 100 iloop=1,nloop

	if(iloop.eq.nloop/2)then
	write(6,*) 'I am half way thru...'
	endif

c calculate Go
	do 2 i=L+1,2*L
	om=(float(i)-XL-1.)*f
	sig=1.d0
	ome=om*one

	if(iloop.eq.1)then
c choose a Go seed in the first loop***

	 if(dabs(om).lt.1.d-9)then
	  g0(i)=0.*one
	else
	  g0(i)=1./(ome+float(imet)*d0*xi/2.)
	endif

	else
c calculate a new Go from the last Sigma

	xs=sf(i-L-1)
	sq=cdsqrt((ome-xs)**2-d0**2*one)
	sqim=dimag(sq)
	sqre=dreal(sq)

	if(i.le.L+5)then
c get the first five frequency points on the right branch-cut
		if(sqre.gt.0..and.imet.eq.0)sig=-1.d0
	else
c choose the branch based on continuity criterium
		benpr=dreal(2./(ome+xs+sq))
	 	benmr=dreal(2./(ome+xs-sq))
	 	benpi=dimag(2./(ome+xs+sq))
		benmi=dimag(2./(ome+xs-sq))
		xp=((benpr+benchr0-2.*benchr)**2
     $    	+(benpi+benchi0-2.*benchi)**2)
		xm=((benmr+benchr0-2.*benchr)**2
     $    	+(benmi+benchi0-2.*benchi)**2)
		if(xp.gt.xm)sig=-1.d0
        	g=(2./(ome+xs+sq))
        	d1=dimag(one/g)-dimag(sf(i-L-1))
        	d2=dreal(one/g)-dreal(sf(i-L-1))
        	d2=d2**2
        	d3=d1**2
        	dn=d1/(d2+d3)
        	if(dn.lt.0)sig=-1.
	endif

c this is the new Go
	g0(i)=2./(ome+xs+sig*sq)

	endif

	benchr=dreal(g0(i))
	benchi=dimag(g0(i))
	benchr0=dreal(g0(i-1))
	benchi0=dimag(g0(i-1))
2	continue

c writes the omega < 0 part of Go for "causal" GF
	do 222 i=1,L-1
	g0(L+1-i)=-g0(L+1+i)
222	continue

c fix the end-point
	g0(1)=g0(2)
c fix the Go(omega=0) equal to 0   (L+1-point)
	g0(L+1)=0.*one

c*** g0 is Go(omega)

c-------------------------------------
c FFT from omega to time
        do i=1,2*L
        tg0(i)=g0(i)
        enddo
        call four1(tg0,L2,1)

	ex=-1.
        do 3 i=1,2*L
	ex=-ex
           tg0(i)=ex*f/2./pi*tg0(i)
 3      continue

        do 4 i=1,L
           fg0(i-1)=tg0(i)
 4      continue

        do 5 i=L+1,2*L
           fg0(-2*L-1+i)=tg0(i)
 5      continue

c *** fg0(i) is  Go(t)
c-------------------------------------

c computes the Sigma*************************
c   Sigma(t) =  U^2/4 * Go^3(t)

	do 7 i=-L+1,L-1
	sft(i)=-u**2*fg0(i)**2*fg0(-i)
7	continue
	sft(-L)=-u**2*fg0(-L)**2*fg0(L-1)

        do 24 i=-L,L-1
	   sft2(i+L+1)=sft(i)
 24      continue

c********************************************

c-------------------------------------
c FFT from time to omega

        do i=1,2*L
        sf2(i)=sft2(i)
        enddo
        call four1(sf2,L2,-1)

	ex=-1.
	do 8 i=1,2*L
	ex=-ex
	sf2(i)=-ex*dtau*sf2(i)
8	continue

        do 34 i=1,L
           sf(i-1)=sf2(i)
34      continue

        do 35 i=L+1,2*L
           sf(-2*L-1+i)=sf2(i)
35      continue

c*** sf is Sigma(omega)
c-------------------------------------

c print output data********************************************

        if(iloop.eq.1.and.imet.eq.1)then
c get the first loop Im[G(w)]  (impurity problem, no sc)*********
        do 110 i=1,2*L
        if(i.eq.L+1)then
c computes the value of Im[G(0)]
        dns0(i)=2.*float(imet)/d0
        else
c computes the value of Im[G(w)]
        d1=dimag(one/g0(i))-dimag(sf(i-L-1))
        d2=dreal(one/g0(i))-dreal(sf(i-L-1))
        d2=d2**2
        d3=d1**2
        dns0(i)=d1/(d2+d3)
        endif
110     continue
	endif

	if(iloop.gt.nl0)then
c get the self-consistent Im[G(w)]****************
	do 111 i=1,2*L
	if(i.eq.L+1)then
c computes the value of Im[G(0)]
	dns(i)=2.d0*dfloat(imet)/d0
	else
c computes the value of Im[G(w)]
	d1=dimag(one/g0(i))-dimag(sf(i-L-1))
	d2=dreal(one/g0(i))-dreal(sf(i-L-1))
	d2=d2**2
	d3=d1**2
	dns(i)=d1/(d2+d3)
	endif
111	continue

c print output files
c fort.25 is Im[G(w)]   (the DOS)
c fort.23 is Re[Sigma(w)]
c fort.24 is Im[Sigma(w)]
c fort.26 is Im[G(w)]  (impurity problem, no self-consistency, imet=1)

	do  i=imax2,imax1+1,-i02
        write(26,*)-real(f*float(i)),(dns0(i+L+1))
        write(25,*)-real(f*float(i)),(dns(i+L+1))
 	write(24,*)-real(f*float(i)),dabs(dimag(sf(-i)))
        write(23,*)-real(f*float(i)),(dreal(sf(-i)))
c	write(27,*)-real(f*float(i)),dreal(dreal(g0(i+L+1)))
c	write(28,*)-real(f*float(i)),dreal(dimag(g0(i+L+1)))
	enddo

        do i=imax1,0,-i01
        write(26,*)-real(f*float(i)),(dns0(i+L+1))
        write(25,*)-real(f*float(i)),(dns(i+L+1))
 	write(24,*)-real(f*float(i)),dabs(dimag(sf(-i)))
        write(23,*)-real(f*float(i)),(dreal(sf(-i)))
c	write(27,*)-real(f*float(i)),dreal(dreal(g0(i+L+1)))
c	write(28,*)-real(f*float(i)),dreal(dimag(g0(i+L+1)))
	enddo

	do 118 i=1,imax1,i01
        write(26,*)real(f*float(i)),(dns0(i+L+1))
	write(25,*)real(f*float(i)),(dns(i+L+1))
 	write(24,*)real(f*float(i)),dabs(dimag(sf(i)))
 	write(23,*)real(f*float(i)),(dreal(sf(i)))
c	write(27,*)real(f*float(i)),dreal(dreal(g0(i+L+1)))
c	write(28,*)real(f*float(i)),dreal(dimag(g0(i+L+1)))
118	continue

	do 116 i=imax1+1,imax2,i02
        write(26,*)real(f*float(i)),(dns0(i+L+1))
	write(25,*)real(f*float(i)),(dns(i+L+1))
 	write(24,*)real(f*float(i)),dabs(dimag(sf(i)))
 	write(23,*)real(f*float(i)),(dreal(sf(i)))
c	write(27,*)real(f*float(i)),dreal(dreal(g0(i+L+1)))
c	write(28,*)real(f*float(i)),dreal(dimag(g0(i+L+1)))
116	continue

 	write(23,*)'    '
 	write(24,*)'    '
	write(25,*)'    '
 	write(26,*)'    '
c	write(27,*)'    '
c	write(28,*)'    '
	endif
c*************************************************************

c go back to the self consistency loop
100	continue

	stop
	end

c########################################################
      SUBROUTINE four1(data,nn,isign)
        implicit real*8(a-h,o-z)
        double precision data(2*nn)
c     INTEGER isign,nn
c     REAL data(2*nn)
c     INTEGER i,istep,j,m,mmax,n
c     REAL tempi,tempr
c     DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      n=2*nn
      j=1
      do 11 i=1,n,2
        if(j.gt.i)then
          tempr=data(j)
          tempi=data(j+1)
          data(j)=data(i)
          data(j+1)=data(i+1)
          data(i)=tempr
          data(i+1)=tempi
        endif
        m=n/2
1       if ((m.ge.2).and.(j.gt.m)) then
          j=j-m
          m=m/2
        goto 1
        endif
        j=j+m
11    continue
      mmax=2
2     if (n.gt.mmax) then
        istep=2*mmax
        theta=6.28318530717959d0/(isign*mmax)
        wpr=-2.d0*dsin(0.5d0*theta)**2
        wpi=dsin(theta)
        wr=1.d0
        wi=0.d0
        do 13 m=1,mmax,2
          do 12 i=m,n,istep
            j=i+mmax
            tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1)
            tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j)
            data(j)=data(i)-tempr
            data(j+1)=data(i+1)-tempi
            data(i)=data(i)+tempr
            data(i+1)=data(i+1)+tempi
12        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
13      continue
        mmax=istep
      goto 2
      endif
      return
      END

c########################################################
c########################################################


C     LAST UPDATE 16/04/91
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE GAUSSIAN
      IMPLICIT NONE
C
C Purpose: Generate a 2-D gaussian function
C
      INCLUDE 'COMMON.FOR'
C
C Calls   5: WFRAME , GETVAL , IMDISP , OPNNEW , OUTFIL
C Called by: BSL
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    VALUE(10),XSQ,YSQ,SQNX,SQNY,RNX,RNY
      INTEGER NPIX,NRAST,IRC,IMEM,KPIC,IFRAME
      INTEGER I,J,K,ICENTX,ICENTY,NVAL
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 OFNAM
C
C IRC    : Return code
C IFRAME : Total nos. of frames
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NFRAME : Nos of time frames
C NVAL   : Nos. of numeric values entered
C
      DATA  IMEM/1/ , KPIC/1/ , IFRAME/1/
C
C-----------------------------------------------------------------------
      NPIX = 512
      NRAST = 512
 10   WRITE (IPRINT,1000) NPIX,NRAST
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 50
      IF (IRC.EQ.2) GOTO 10
      IF (NVAL.GT.0) NPIX=INT(VALUE(1))
      IF (NVAL.GT.1) NRAST=INT(VALUE(2))
C
      ICENTX=(NPIX/2)+1
      ICENTY=(NRAST/2)+1
15    WRITE (IPRINT,1010) ICENTX,ICENTY
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 50
      IF (IRC.EQ.2) GOTO 15
      IF (NVAL.GT.0) ICENTX=INT(VALUE(1))
      IF (NVAL.GT.1) ICENTY=INT(VALUE(2))
C
      RNX = 1.0
      RNY = 1.0
20    WRITE (IPRINT,1020)
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 50
      IF (IRC.EQ.2) GOTO 20
      IF (NVAL.GT.0) RNX=VALUE(1)
      IF (NVAL.GT.1) RNY=VALUE(2)
C
C========GENERATE THE FUNCTION
C
      SQNX = (1.0/RNX)*(1.0/RNX)
      SQNY = (1.0/RNY)*(1.0/RNY)
cx      print *,nx,ny,sqnx,sqny
      K=1
      DO 40 I=1,NRAST
         YSQ=(I-ICENTY)*(I-ICENTY)
         DO 30 J=1,NPIX
            XSQ=(J-ICENTX)*(J-ICENTX)
            SP3(K)=EXP(-(SQNX*XSQ + SQNY*YSQ))
cx            print *,k,xsq,ysq,(SQNX*XSQ + SQNY*YSQ),sp3(k)
            K=K+1
30       CONTINUE
40    CONTINUE
C
C==========DISPLAY & OUTPUT FUNCTION
C
      CALL IMDISP (ITERM,IPRINT,SP3,NPIX,NRAST)
      CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
      IF (IRC.NE.0) GOTO 50
      CALL OPNNEW (LUNIT,NPIX,NRAST,IFRAME,OFNAM,IMEM,HEAD1,HEAD2,IRC)
      IF (IRC.NE.0) GOTO 50
      CALL WFRAME (LUNIT,KPIC,NPIX,NRAST,SP3,IRC)
50    CALL FCLOSE (LUNIT)
999   RETURN
C
1000  FORMAT (' Enter nos of pixels and rasters for image',
     &        ' [',I4,',',I4,'] : ',$)
1010  FORMAT (' Enter x,y coordinate for image centre',
     &        ' [',I4,',',I4,'] : ',$)
1020  FORMAT (' Enter x-factor,yfactor: ',$)
      END


      program convdif
c-----------------------------------------------------------------------
c this driver will generate a finite element matrix for the
c convection-diffusion problem
c
c                  - Div ( K(x,y) Grad u ) + C grad u = f
c                    u = 0 on boundary
c
c (Dirichlet boundary conditions).
c-----------------------------------------------------------------------
c this code will prompt for desired mesh (from 0 to 9, with one being
c a user input one) and will general the matrix in harewell-Boeing format
c in the file mat.hb. It also generates two post script files, one
c showing the pattern of the matrix (mat.ps) and the other showing the
c corresponding mesh (msh.ps).
c-----------------------------------------------------------------------
c the structure and organization of the fem codes follow very closely
c that of the book by Noborou Kikuchi (Finite element methods in
c mechanics,   Cambridge Univ. press, 1986).
c-----------------------------------------------------------------------
c coded Y. Saad and S. Ma -- this version dated August 11, 1993
c-----------------------------------------------------------------------
      implicit none
      integer maxnx, maxnel
      parameter (maxnx = 8000, maxnel = 15000)
      real*8 a(7*maxnx),x(maxnx),y(maxnx),f(3*maxnx)
      integer ijk(3,maxnel),ichild(12,maxnel),iparnts(2,maxnx),
     *     ia(maxnx),ja(7*maxnx),iwk(maxnx),jwk(maxnx),nodcode(maxnx),
     *     iperm(maxnx)
c
      character matfile*20, title*72, munt*2,key*8, type*3
      real size
c
      integer iin,node,nx,nelx,iout,ndeg,na,nmesh,nref,nxmax,nelmax,nb,
     *    ii,nxnew, nelxnew,ierr,job,n,ncol,mode,ptitle,ifmt
      external xyk, funb, func, fung
      data iin/7/,node/3/,nx/0/,nelx/0/,iout/8/,ndeg/12/, na/3000/
c--------------------------------------------------------------
c choose starting mesh   ---
c--------------------------------------------------------------
c     files for output
c
      open(unit=10,file='mat.hb')
      open(unit=11,file='msh.ps')
      open(unit=12,file='mat.ps')
c-----------------------------------------------------------------------
      print *, ' enter chosen mesh '
      read (*,*) nmesh
      if (nmesh .eq. 0) then
         print *, 'enter input file for initial mesh '
         read(*,'(a20)') matfile
         open (unit=7,file=matfile)
      endif
c-----------------------------------------------------------------------
      print *, ' Enter the number of refinements desired '
      read (*,*) nref
      call inmesh (nmesh,iin,nx,nelx,node,x,y,nodcode,ijk,iperm)
c
c     ...REFINE THE GRID
c
      nxmax = maxnx
      nelmax= maxnel
      nb = 0
      do 10 ii = 1, nref
c
c     estimate the number nx and nelx at next refinement level.
c
         call checkref(nx,nelx,nodcode,nb,nxnew,nelxnew)
         if (nxnew .gt. nxmax .or. nelxnew .gt. nelmax) then
	    print *, ' Was able to do only ', ii-1 ,'  refinements'
	    goto 11
         endif
c
c     ...if OK refine  all elements
c
         call refall(nx,nelx,ijk,node,ndeg,x,y,ichild,iparnts,nodcode,
     *        nxmax, nelmax, ierr)
         if (ierr .ne. 0) print *, '** ERROR IN REFALL : ierr =',ierr
 10   continue
 11   continue
c-----------------------------------------------------------------------
      job = 0
c-----------------------------------------------------------------------
c     assemble the matrix in CSR format
c-----------------------------------------------------------------------
      call assmbo (nx,nelx,node,ijk,nodcode,x,y,
     *     a,ja,ia,f,iwk,jwk,ierr,xyk,funb,func,fung)
      n = nx
c----------------------Harewell-Boeing matrix---------------------------
c---------------------1---------2---------3---------5---------6
c            12345678901234567890123456789012345678901234567890
      title='1Sample matrix from SPARSKIT  '
      key = 'SPARSKIT'
      type = 'rua'
      ifmt = 6
      job = 2
      call prtmt (n,n,a,ja,ia,f,'NN',title,key,type,ifmt,job,10)
c----------------------Plot of mesh-------------------------------------
c-----------------------------------------------------------------------
      size = 6.0
      munt = 'in'
      mode = 0
      title ='Finite element mesh '
      ptitle = 1
      call psgrid (nx,ja,ia,x,y,title,ptitle,size,munt,11)
c      hsize  = 5.6
c      vsize = 5.6
c      xleft = 0.0
c      bot = 0.0
c      job = 30
c      call texgrd(nx,ja,ia,x,y,munt,size,vsize,hsize,
c     *     xleft,bot,job,title,ptitle,ijk,node,nelx,11)
c----------------------Plot of matrix-pattern---------------------------
c-----------------------------------------------------------------------
      size = 5.5
      mode = 0
      title = 'Assembled Matrix'
      ptitle = 1
      ncol = 0
      iout = 12
      call pspltm(n,n,mode,ja,ia,title,ptitle,size,munt,ncol,iwk,12)
c      xleft = 0.00
c      bot = 0.70
c      job =  0
c      call texplt(nx,nx,mode,ja,ia,munt,size,vsize,hsize,xleft,bot,
c     *     job,title,ptitle,ncol,iwk,12)
      stop
c-----end-of-program-convdif--------------------------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------


program main

!*****************************************************************************80
!
!! MAIN is the main program for MD.
!
!  Discussion:
!
!    MD implements a simple molecular dynamics simulation.
!
!    The velocity Verlet time integration scheme is used.
!
!    The particles interact with a central pair potential.
!
!    Based on a FORTRAN90 program by Bill Magro.
!
!  Usage:
!
!    md nd np step_num dt
!
!    where
!
!    * nd is the spatial dimension (2 or 3);
!    * np is the number of particles (500, for instance);
!    * step_num is the number of time steps (500, for instance).
!    * dt is the time step (0.1 for instance )
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 December 2014
!
!  Author:
!
!    John Burkardt
!
  implicit none

  real ( kind = 8 ), allocatable :: acc(:,:)
  integer ( kind = 4 ) arg_num
  real ( kind = 8 ) ctime
  real ( kind = 8 ) ctime1
  real ( kind = 8 ) ctime2
  real ( kind = 8 ) dt
  real ( kind = 8 ) e0
  real ( kind = 8 ), allocatable :: force(:,:)
  integer ( kind = 4 ) iarg
  integer ( kind = 4 ) id
  integer ( kind = 4 ) ierror
  real ( kind = 8 ) kinetic
  integer ( kind = 4 ) last
  real ( kind = 8 ), parameter :: mass = 1.0D+00
  integer ( kind = 4 ) nd
  integer ( kind = 4 ) np
  real ( kind = 8 ), allocatable :: pos(:,:)
  real ( kind = 8 ) potential
  real ( kind = 8 ) rel
  integer ( kind = 4 ) step
  integer ( kind = 4 ) step_num
  integer ( kind = 4 ) step_print
  integer ( kind = 4 ) step_print_index
  integer ( kind = 4 ) step_print_num
  character ( len = 255 ) string
  real ( kind = 8 ), allocatable :: vel(:,:)
  real ( kind = 8 ) wtime

  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MD'
  write ( *, '(a)' ) '  FORTRAN90 version'
  write ( *, '(a)' ) '  A molecular dynamics program.'
!
!  Get the number of command line arguments.
!
  arg_num = iargc ( )
!
!  Get ND, the number of spatial dimensions.
!
  if ( 1 <= arg_num ) then
    iarg = 1
    call getarg ( iarg, string )
    call s_to_i4 ( string, nd, ierror, last )
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Enter ND, the spatial dimension (2 or 3 ):'
    read ( *, * ) nd
  end if
!
!  Get NP, the number of particles.
!
  if ( 2 <= arg_num ) then
    iarg = 2
    call getarg ( iarg, string )
    call s_to_i4 ( string, np, ierror, last )
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) &
      '  Enter NP, the number of particles (500, for instance):'
    read ( *, * ) np
  end if
!
!  Get STEP_NUM, the number of time steps.
!
  if ( 3 <= arg_num ) then
    iarg = 3
    call getarg ( iarg, string )
    call s_to_i4 ( string, step_num, ierror, last )
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) &
      '  Enter STEP_NUM, the number of time steps (500, for instance):'
    read ( *, * ) step_num
  end if
!
!  Get DT, the time step.
!
  if ( 4 <= arg_num ) then
    iarg = 4
    call getarg ( iarg, string )
    call s_to_r8 ( string, dt  )
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) &
      '  Enter DT, the time step size (0.1, for instance):'
    read ( *, * ) dt
  end if
!
!  Report.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a,i8)' ) '  ND, the spatial dimension, is ', nd
  write ( *, '(a,i8)' ) &
    '  NP, the number of particles in the simulation is ', np
  write ( *, '(a,i8)' ) '  STEP_NUM, the number of time steps, is ', step_num
  write ( *, '(a,g14.6)' ) '  DT, the size of each time step, is ', dt
!
!  Allocate memory.
!
  allocate ( acc(nd,np) )
  allocate ( force(nd,np) )
  allocate ( pos(nd,np) )
  allocate ( vel(nd,np) )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '  At each step, we report the potential and kinetic energies.'
  write ( *, '(a)' ) '  The sum of these energies should be a constant.'
  write ( *, '(a)' ) '  As an accuracy check, we also print the relative error'
  write ( *, '(a)' ) '  in the total energy.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '      Step      Potential       Kinetic        (P+K-E0)/E0'
  write ( *, '(a)' ) &
    '                Energy P        Energy K       Relative Energy Error'
  write ( *, '(a)' ) ' '
!
!  This is the main time stepping loop:
!    Initialize or update positions, velocities, accelerations.
!    Compute forces and energies,
!
  step_print = 0
  step_print_index = 0
  step_print_num = 10

  call cpu_time ( ctime1 )

  do step = 0, step_num

    if ( step == 0 ) then
      call initialize ( np, nd, pos, vel, acc )
    else
      call update ( np, nd, pos, vel, force, acc, mass, dt )
    end if

    call compute ( np, nd, pos, vel, mass, force, potential, kinetic )

    if ( step == 0 ) then
      e0 = potential + kinetic
    end if

    if ( step == step_print ) then
      rel = ( potential + kinetic - e0 ) / e0
      write ( *, '(2x,i8,2x,g14.6,2x,g14.6,2x,g14.6)' ) &
        step, potential, kinetic, rel
      step_print_index = step_print_index + 1
      step_print = ( step_print_index * step_num ) / step_print_num
    end if

  end do
!
!  Report time.
!
  call cpu_time ( ctime2 )
  ctime = ctime2 - ctime1
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Elapsed cpu time for main computation:'
  write ( *, '(2x,g14.6,a)' ) ctime, ' seconds'
!
!  Free memory.
!
  deallocate ( acc )
  deallocate ( force )
  deallocate ( pos )
  deallocate ( vel )
!
!  Terminate.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MD:'
  write ( *, '(a)' ) '  Normal end of execution.'
  write ( *, '(a)' ) ' '
  call timestamp ( )

  stop
end
subroutine compute ( np, nd, pos, vel, mass, f, pot, kin )

!*****************************************************************************80
!
!! COMPUTE computes the forces and energies.
!
!  Discussion:
!
!    The computation of forces and energies is fully parallel.
!
!    The potential function V(X) is a harmonic well which smoothly
!    saturates to a maximum value at PI/2:
!
!      v(x) = ( sin ( min ( x, PI/2 ) ) )^2
!
!    The derivative of the potential is:
!
!      dv(x) = 2.0D+00 * sin ( min ( x, PI/2 ) ) * cos ( min ( x, PI/2 ) )
!            = sin ( 2.0 * min ( x, PI/2 ) )
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    15 July 2008
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Input, real ( kind = 8 ) POS(ND,NP), the positions.
!
!    Input, real ( kind = 8 ) VEL(ND,NP), the velocities.
!
!    Input, real ( kind = 8 ) MASS, the mass.
!
!    Output, real ( kind = 8 ) F(ND,NP), the forces.
!
!    Output, real ( kind = 8 ) POT, the total potential energy.
!
!    Output, real ( kind = 8 ) KIN, the total kinetic energy.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) d
  real ( kind = 8 ) d2
  real ( kind = 8 ) f(nd,np)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) kin
  real ( kind = 8 ) mass
  real ( kind = 8 ), parameter :: PI2 = 3.141592653589793D+00 / 2.0D+00
  real ( kind = 8 ) pos(nd,np)
  real ( kind = 8 ) pot
  real ( kind = 8 ) rij(nd)
  real ( kind = 8 ) vel(nd,np)

  pot = 0.0D+00

  do i = 1, np
!
!  Compute the potential energy and forces.
!
    f(1:nd,i) = 0.0D+00

    do j = 1, np

      if ( i /= j ) then

        rij(1:nd) = pos(1:nd,i) - pos(1:nd,j)

        d = sqrt ( sum ( rij(1:nd)**2 ) )
!
!  Truncate the distance.
!
        d2 = min ( d, PI2 )
!
!  Attribute half of the total potential energy to particle J.
!
        pot = pot + 0.5D+00 * sin ( d2 ) * sin ( d2 )
!
!  Add particle J's contribution to the force on particle I.
!
        f(1:nd,i) = f(1:nd,i) - rij(1:nd) * sin ( 2.0D+00 * d2 ) / d

      end if

    end do

  end do
!
!  Compute the total kinetic energy.
!
  kin = 0.5D+00 * mass * sum ( vel(1:nd,1:np)**2 )

  return
end
subroutine initialize ( np, nd, pos, vel, acc )

!*****************************************************************************80
!
!! INITIALIZE initializes the positions, velocities, and accelerations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 December 2014
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Output, real ( kind = 8 ) POS(ND,NP), the positions.
!
!    Output, real ( kind = 8 ) VEL(ND,NP), the velocities.
!
!    Output, real ( kind = 8 ) ACC(ND,NP), the accelerations.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) acc(nd,np)
  real ( kind = 8 ) pos(nd,np)
  integer ( kind = 4 ) seed
  real ( kind = 8 ) vel(nd,np)
!
!  Set the positions.
!
  seed = 123456789
  call r8mat_uniform_ab ( nd, np, 0.0D+00, 10.0D+00, seed, pos )
!
!  Set the velocities.
!
  vel(1:nd,1:np) = 0.0D+00
!
!  Set the accelerations.
!
  acc(1:nd,1:np) = 0.0D+00

  return
end
subroutine r8mat_uniform_ab ( m, n, a, b, seed, r )

!*****************************************************************************80
!
!! R8MAT_UNIFORM_AB returns a scaled pseudorandom R8MAT.
!
!  Discussion:
!
!    A <= R(I,J) <= B.
!
!    An R8MAT is an array of R8's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, Number 2, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns
!    in the array.
!
!    Input, real ( kind = 8 ) A, B, the lower and upper limits.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) i
  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(m,n)

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R8MAT_UNIFORM_AB - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop 1
  end if

  do j = 1, n

    do i = 1, m

      k = seed / 127773

      seed = 16807 * ( seed - k * 127773 ) - k * 2836

      if ( seed < 0 ) then
        seed = seed + i4_huge
      end if

      r(i,j) = a + ( b - a ) * real ( seed, kind = 8 ) * 4.656612875D-10

    end do
  end do

  return
end
subroutine s_to_i4 ( s, value, ierror, length )

!*****************************************************************************80
!
!! S_TO_I4 reads an integer value from a string.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 January 2009
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, a string to be examined.
!
!    Output, integer ( kind = 4 ) VALUE, the integer value read from the string.
!    If the string is blank, then VALUE will be returned 0.
!
!    Output, integer ( kind = 4 ) IERROR, an error flag.
!    0, no error.
!    1, an error occurred.
!
!    Output, integer ( kind = 4 ) LENGTH, the number of characters
!    of S used to make the integer.
!
  implicit none

  character c
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) isgn
  integer ( kind = 4 ) length
  character ( len = * ) s
  integer ( kind = 4 ) state
  character :: TAB = achar ( 9 )
  integer ( kind = 4 ) value

  value = 0
  ierror = 0
  length = 0

  state = 0
  isgn = 1

  do i = 1, len_trim ( s )

    c = s(i:i)
!
!  STATE = 0, haven't read anything.
!
    if ( state == 0 ) then

      if ( c == ' ' .or. c == TAB ) then

      else if ( c == '-' ) then
        state = 1
        isgn = -1
      else if ( c == '+' ) then
        state = 1
        isgn = +1
      else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then
        state = 2
        value = iachar ( c ) - iachar ( '0' )
      else
        ierror = 1
        return
      end if
!
!  STATE = 1, have read the sign, expecting digits or spaces.
!
    else if ( state == 1 ) then

      if ( c == ' ' .or. c == TAB ) then

      else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then
        state = 2
        value = iachar ( c ) - iachar ( '0' )
      else
        ierror = 1
        return
      end if
!
!  STATE = 2, have read at least one digit, expecting more.
!
    else if ( state == 2 ) then

      if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then

        value = 10 * value + iachar ( c ) - iachar ( '0' )

      else

        value = isgn * value
        ierror = 0
        length = i - 1
        return

      end if

    end if

  end do
!
!  If we read all the characters in the string, see if we're OK.
!
  if ( state == 2 ) then

    value = isgn * value
    ierror = 0
    length = len_trim ( s )

  else

    value = 0
    ierror = 1
    length = 0

  end if

  return
end
subroutine s_to_r8 ( s, r8 )

!*****************************************************************************80
!
!! S_TO_R8 reads an R8 value from a string.
!
!  Discussion:
!
!    An "R8" value is simply a real number to be stored as a
!    variable of type "real ( kind = 8 )".
!
!    The routine will read as many characters as possible until it reaches
!    the end of the string, or encounters a character which cannot be
!    part of the number.
!
!    Legal input is:
!
!       1 blanks,
!       2 '+' or '-' sign,
!       2.5 blanks
!       3 integer part,
!       4 decimal point,
!       5 fraction part,
!       6 'E' or 'e' or 'D' or 'd', exponent marker,
!       7 exponent sign,
!       8 exponent integer part,
!       9 exponent decimal point,
!      10 exponent fraction part,
!      11 blanks,
!      12 final comma or semicolon,
!
!    with most quantities optional.
!
!  Example:
!
!    S                 R8
!
!    '1'               1.0
!    '     1   '       1.0
!    '1A'              1.0
!    '12,34,56'        12.0
!    '  34 7'          34.0
!    '-1E2ABCD'        -100.0
!    '-1X2ABCD'        -1.0
!    ' 2E-1'           0.2
!    '23.45'           23.45
!    '-4.2E+2'         -420.0
!    '17d2'            1700.0
!    '-14e-2'         -0.14
!    'e2'              100.0
!    '-12.73e-9.23'   -12.73 * 10.0^(-9.23)
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 January 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string containing the
!    data to be read.  Reading will begin at position 1 and
!    terminate at the end of the string, or when no more
!    characters can be read to form a legal real.  Blanks,
!    commas, or other nonnumeric data will, in particular,
!    cause the conversion to halt.
!
!    Output, real ( kind = 8 ) R8, the value read from the string.
!
  implicit none

  character c
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) ihave
  integer ( kind = 4 ) isgn
  integer ( kind = 4 ) iterm
  integer ( kind = 4 ) jbot
  integer ( kind = 4 ) jsgn
  integer ( kind = 4 ) jtop
  integer ( kind = 4 ) length
  integer ( kind = 4 ) ndig
  real ( kind = 8 ) r8
  real ( kind = 8 ) rbot
  real ( kind = 8 ) rexp
  real ( kind = 8 ) rtop
  character ( len = * ) s
  integer ( kind = 4 ) s_length
  character  :: TAB = achar ( 9 )

  s_length = len_trim ( s )

  ierror = 0
  r8 = 0.0D+00
  length = -1
  isgn = 1
  rtop = 0
  rbot = 1
  jsgn = 1
  jtop = 0
  jbot = 1
  ihave = 1
  iterm = 0

  do

    length = length + 1

    if ( s_length < length + 1 ) then
      exit
    end if

    c = s(length+1:length+1)
!
!  Blank character.
!
    if ( c == ' ' .or. c == TAB ) then

      if ( ihave == 2 ) then

      else if ( ihave == 6 .or. ihave == 7 ) then
        iterm = 1
      else if ( 1 < ihave ) then
        ihave = 11
      end if
!
!  Comma.
!
    else if ( c == ',' .or. c == ';' ) then

      if ( ihave /= 1 ) then
        iterm = 1
        ihave = 12
        length = length + 1
      end if
!
!  Minus sign.
!
    else if ( c == '-' ) then

      if ( ihave == 1 ) then
        ihave = 2
        isgn = -1
      else if ( ihave == 6 ) then
        ihave = 7
        jsgn = -1
      else
        iterm = 1
      end if
!
!  Plus sign.
!
    else if ( c == '+' ) then

      if ( ihave == 1 ) then
        ihave = 2
      else if ( ihave == 6 ) then
        ihave = 7
      else
        iterm = 1
      end if
!
!  Decimal point.
!
    else if ( c == '.' ) then

      if ( ihave < 4 ) then
        ihave = 4
      else if ( 6 <= ihave .and. ihave <= 8 ) then
        ihave = 9
      else
        iterm = 1
      end if
!
!  Scientific notation exponent marker.
!
    else if ( c == 'E' .or. c == 'e' .or. c == 'D' .or. c == 'd' ) then

      if ( ihave < 6 ) then
        ihave = 6
      else
        iterm = 1
      end if
!
!  Digit.
!
    else if (  ihave < 11 .and. lle ( '0', c ) .and. lle ( c, '9' ) ) then

      if ( ihave <= 2 ) then
        ihave = 3
      else if ( ihave == 4 ) then
        ihave = 5
      else if ( ihave == 6 .or. ihave == 7 ) then
        ihave = 8
      else if ( ihave == 9 ) then
        ihave = 10
      end if

      ndig = iachar ( c ) - 48

      if ( ihave == 3 ) then
        rtop = 10.0D+00 * rtop + real ( ndig, kind = 8 )
      else if ( ihave == 5 ) then
        rtop = 10.0D+00 * rtop + real ( ndig, kind = 8 )
        rbot = 10.0D+00 * rbot
      else if ( ihave == 8 ) then
        jtop = 10 * jtop + ndig
      else if ( ihave == 10 ) then
        jtop = 10 * jtop + ndig
        jbot = 10 * jbot
      end if
!
!  Anything else is regarded as a terminator.
!
    else
      iterm = 1
    end if
!
!  If we haven't seen a terminator, and we haven't examined the
!  entire string, go get the next character.
!
    if ( iterm == 1 ) then
      exit
    end if

  end do
!
!  If we haven't seen a terminator, and we have examined the
!  entire string, then we're done, and LENGTH is equal to S_LENGTH.
!
  if ( iterm /= 1 .and. length + 1 == s_length ) then
    length = s_length
  end if
!
!  Number seems to have terminated.  Have we got a legal number?
!  Not if we terminated in states 1, 2, 6 or 7!
!
  if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then
    ierror = ihave
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'S_TO_R8 - Serious error!'
    write ( *, '(a)' ) '  Illegal or nonnumeric input:'
    write ( *, '(a)' ) '    "' // trim ( s ) // '"'
    stop 1
  end if
!
!  Number seems OK.  Form it.
!
  if ( jtop == 0 ) then
    rexp = 1.0D+00
  else
    if ( jbot == 1 ) then
      rexp = 10.0D+00 ** ( jsgn * jtop )
    else
      rexp = 10.0D+00 ** ( real ( jsgn * jtop, kind = 8 ) &
        / real ( jbot, kind = 8 ) )
    end if
  end if

  r8 = real ( isgn, kind = 8 ) * rexp * rtop / rbot

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end
subroutine update ( np, nd, pos, vel, f, acc, mass, dt )

!*****************************************************************************80
!
!! UPDATE updates positions, velocities and accelerations.
!
!  Discussion:
!
!    The time integration is fully parallel.
!
!    A velocity Verlet algorithm is used for the updating.
!
!    x(t+dt) = x(t) + v(t) * dt + 0.5 * a(t) * dt * dt
!    v(t+dt) = v(t) + 0.5 * ( a(t) + a(t+dt) ) * dt
!    a(t+dt) = f(t) / m
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 November 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Input/output, real ( kind = 8 ) POS(ND,NP), the positions.
!
!    Input/output, real ( kind = 8 ) VEL(ND,NP), the velocities.
!
!    Input, real ( kind = 8 ) F(ND,NP), the forces.
!
!    Input/output, real ( kind = 8 ) ACC(ND,NP), the accelerations.
!
!    Input, real ( kind = 8 ) MASS, the mass of each particle.
!
!    Input, real ( kind = 8 ) DT, the time step.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) acc(nd,np)
  real ( kind = 8 ) dt
  real ( kind = 8 ) f(nd,np)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) mass
  real ( kind = 8 ) pos(nd,np)
  real ( kind = 8 ) rmass
  real ( kind = 8 ) vel(nd,np)

  rmass = 1.0D+00 / mass

  do j = 1, np
    do i = 1, nd
      pos(i,j) = pos(i,j) + vel(i,j) * dt + 0.5D+00 * acc(i,j) * dt * dt
      vel(i,j) = vel(i,j) + 0.5D+00 * dt * ( f(i,j) * rmass + acc(i,j) )
      acc(i,j) = f(i,j) * rmass
    end do
  end do

  return
end


module combinations_module
   use iso_fortran_env
implicit none
contains
!
!----------------------------------
!combinations - function:
!----------------------------------
!
integer function combination_x_of_p(x,p)
implicit none
!
integer(kind=int64), intent(in) :: x, p
integer(kind=int64) :: diff, prod, x_fact, p_x_fact, i
!
diff = p - x
write(*,*) 'x', x, 'p', p
write(*,*) 'diff', diff
!
!--------------------
! p-x > x :
!--------------------
!
if (diff .ge. x) then
   write(*,*) 'p - x > x'
   prod = 1
   do i = 1, x
      prod = prod * (diff + i)
      write(*,*) 'prod', prod
   end do
   !
   if (x .ne. 0) then
      x_fact = 1
      do i = 1, x
         x_fact = x_fact * i
      end do
   end if
   if (x .eq. 0) then
      x_fact = 1
   end if
   !
   write(*,*) 'prod', prod
   write(*,*) 'x_fact', x_fact
   combination_x_of_p = prod/x_fact
   write(*,*) 'combination x of p', combination_x_of_p
!
!--------------------------
! p-x < x :
!--------------------------
!
else if (diff .lt. x) then
   write(*,*) 'x > p - x'
   prod = 1
   do i = 1, diff
      prod = prod * (x+i)
   end do
   !
   p_x_fact = 1
   do i = 1, p - x
      p_x_fact = p_x_fact * i
   end do
   !
   combination_x_of_p = prod/p_x_fact
end if
!
!-----------------------------------------------------------------
! example -> x .lt. p-x
!-----------------------------------------------------------------
!
!   p = 8
!   x = 2
!   p - x = 6
!
!   x < p-x
!
!   6! 7 8            p-x+1 p-x+2
! -------------- = --------------------
!   6! 2!               x!
!
!-----------------------------------------------------------------
! example -> x .gt. p=x
!-----------------------------------------------------------------
!
!   p = 8
!   x = 5
!   p - x = 3
!
!   5! 6 7 8        x+1 x+2 x+3
! ------------ = ------------------
!   5! 3!           p - x!
!
end function combination_x_of_p

end module combinations_module


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module divergence_operators

  use definitions, only: wp,t_grid
  use run_nml,     only: nlins,ncols,nlays,nlays_oro
  use averaging,   only: vertical_contravariant_corr

  implicit none

  private

  public :: divv_h

  contains

  subroutine divv_h(vector_field_x,vector_field_y,result_field,grid)

    ! This subroutine computes the gradient of a scalar field.
    real(wp),     intent(in)    :: vector_field_x(:,:,:) ! x-component of horizontal vector field of which to calculate the divergence
    real(wp),     intent(in)    :: vector_field_y(:,:,:) ! y-component of horizontal vector field of which to calculate the divergence
    real(wp),     intent(inout) :: result_field(:,:,:)   ! resulting scalar field
    type(t_grid), intent(in)    :: grid                  ! the grid properties
    ! local variables
    integer                     :: ji,jk,jl              ! loop variables
    real(wp)                    :: comp_h                ! horizontal component of divergence
    real(wp)                    :: comp_v                ! horizontal component of divergence
    real(wp)                    :: contra_upper          ! contravariant mass flux density resulting
                                                         ! from the horizontal vector components through the upper area
    real(wp)                    :: contra_lower          ! contravariant mass flux density resulting
                                                         ! from the horizontal vector components through the lower area

    ! performing the actual calculation
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl,comp_h,comp_v)
    do ji=1,nlins
      do jk=1,ncols
        do jl=1,nlays
          ! the horizontal component
          comp_h = &
          vector_field_x(ji+1,jk+1,jl)*grid%area_x(ji  ,jk+1,jl) &
          + vector_field_y(ji+1,jk+1,jl)*grid%area_y(ji+1,jk  ,jl) &
          - vector_field_x(ji+1,jk  ,jl)*grid%area_x(ji  ,jk  ,jl) &
          - vector_field_y(ji  ,jk+1,jl)*grid%area_y(ji  ,jk  ,jl)

          ! the vertical component
          comp_v = 0._wp
          if (jl == nlays - nlays_oro) then
            contra_lower = vertical_contravariant_corr(vector_field_x,vector_field_y,ji,jk,jl+1,grid)
            comp_v = -contra_lower*grid%area_z(ji,jk,jl+1)
          elseif (jl == nlays) then
            contra_upper = vertical_contravariant_corr(vector_field_x,vector_field_y,ji,jk,jl  , grid)
            comp_v = contra_upper*grid%area_z(ji,jk,jl  )
          elseif (jl > nlays - nlays_oro - 1) then
            contra_upper = vertical_contravariant_corr(vector_field_x,vector_field_y,ji,jk,jl  ,grid)
            contra_lower = vertical_contravariant_corr(vector_field_x,vector_field_y,ji,jk,jl+1,grid)
            comp_v &
            = contra_upper*grid%area_z(ji,jk,jl  ) &
            - contra_lower*grid%area_z(ji,jk,jl+1)
          endif

          ! adding the horizontal and the vertical component and dividing by the volume
          result_field(ji,jk,jl) = (comp_h + comp_v)/grid%volume(ji,jk,jl)
        enddo
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

  end subroutine divv_h

end module divergence_operators


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
program test_cblktri

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    type(FishpackWorkspace)       :: workspace
    integer(ip), parameter        :: N = 63, M = 50
    integer(ip), parameter        :: IDIMY = 75, NT = 105
    integer(ip)                   :: iflg, np, mp, i, j, ierror
    real(wp), dimension(NT)       :: an, bn, cn, t
    real(wp), dimension(IDIMY)    :: s
    real(wp)                      :: ds, dt
    real(wp), parameter           :: ZERO = 0.0_wp, ONE = 1.0_wp, TWO = 2.0_wp
    complex(wp)                   :: y(IDIMY,NT)
    complex(wp), dimension(IDIMY) :: am, bm, cm
    complex(wp), parameter        :: IMAGINARY_UNIT = cmplx(ZERO, ONE, kind=wp)

    ! Set boundary conditions
    np = 1
    mp = 1

    ! Set mesh sizes
    ds = ONE/(M + 1)
    dt = ONE/(N + 1)

    ! Generate and store grid points for the purpose of computing the
    ! coefficients and the array y.
    do i = 1, M
        s(i) = real(i, kind=wp) * ds
    end do

    do j = 1, N
        t(j) = real(j, kind=wp) * dt
    end do

    ! Compute the coefficients am, bm, cm corresponding to the s direction
    block
        real(wp) :: half_ds, two_ds
        real(wp) :: temp1, temp2, temp3

        half_ds = ds/2
        two_ds = TWO * ds

        do i = 1, M
            temp1 = ONE /(s(i)*two_ds)
            temp2 = ONE /((s(i)-half_ds) * two_ds)
            temp3 = ONE /((s(i)+half_ds) * two_ds)
            am(i) = cmplx(temp1*temp2, ZERO, kind=wp)
            cm(i) = cmplx(temp1*temp3, ZERO, kind=wp)
            bm(i) = (-(am(i)+cm(i))) - IMAGINARY_UNIT
        end do
    end block

    ! Compute the coefficients an, bn, cn corresponding to the t direction
    block
        real(wp) :: half_dt, two_dt
        real(wp) :: temp1, temp2, temp3

        half_dt = dt/2
        two_dt = TWO * dt

        do j = 1, N
            temp1 = ONE/(t(j) * two_dt)
            temp2 = ONE/((t(j) - half_dt) * two_dt)
            temp3 = ONE/((t(j) + half_dt) * two_dt)
            an(j) = temp1 * temp2
            cn(j) = temp1 * temp3
            bn(j) = -(an(j) + cn(j))
        end do
    end block

    ! Compute right side of equation
    do j = 1, N
        y(:M, j) = 3.75_wp * s(:M) * t(j) * (s(:M)**4 + t(j)**4) &
            - IMAGINARY_UNIT * (s(:M)*t(j))**5
    end do

    ! The nonzero boundary conditions enter the linear system via
    ! the right side y(i, j). if the equations (3) given above
    ! are evaluated at i=m and j=1, ..., n then the term cm(m)*u(m+1, j)
    ! is known from the boundary condition to be cm(m)*t(j)**5.
    ! therefore this term can be included in the right side y(m, j).
    ! the same analysis applies at j=n and i=1, .., m. note that the
    ! corner at j=n, i=m includes contributions from both boundaries.
    y(M,:N) = y(M,:N) - cm(M) * (t(:N)**5)
    y(:M,N) = y(:M,N) - cn(N) * (s(:M)**5)

    ! Initialize workspace and lower solver routines
    iflg = 0
    call cblktri(iflg, np, N, an, bn, cn, mp, M, am, bm, cm, IDIMY, y, ierror, workspace)

    ! Solve complex block tridiagonal linear system
    iflg = iflg + 1
    do while(iflg <= 1)
        call cblktri(iflg, np, N, an, bn, cn, mp, M, am, bm, cm, IDIMY, y, ierror, workspace)
        iflg = iflg + 1
    end do

    ! Compute discretization error. The exact solution is
    ! u(s,t) = (st)**5
    block
        real(wp), parameter :: KNOWN_ERROR = 0.164571992877414e-004_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(M, N)

        do j = 1, N
            do i = 1, M
                exact_solution(i,j) = (s(i)*t(j))**5
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution-y(:M,:N)))

        call check_output('cblktri', ierror, KNOWN_ERROR, discretization_error)
    end block

    ! Release memory
    call workspace%destroy()

end program test_cblktri