!
! Defining potential energy function
!
subroutine poten(force,f,r12,r32,theta)
   !
   integer,parameter           :: N = 99
   !
   double precision,intent(in) ::  force(N),r12,r32,theta
   double precision,intent(out)::  f

   double precision            :: xcos,v,v1,v2,v3,v4,v5,v6,v7,v8,alpha

   double precision            :: aa1,re12,alphae,xst,y1,y2,y3,xs1,xs2,v0,vp1,vp2,vp3
   double precision            :: g1,g2,b1,b2,rhh,vhh,th1,th2
   integer                     :: n1
   !
   N1 = size(force)
   !
   alpha = theta
   !
   !write(6,"('r12,r32,alpha = ',3f20.8)") r12,r32,alpha
   !
   re12    = 1.335946936 ! 1.33756337958d0
   alphae  = 92.23305449*3.1415926535897932385/180.d0
   aa1     = 1.8d0
   !
   !re12    = 1.3359007d0
   !alphae  = 92.265883d0*3.1415926535897932385/180.d0
   !aa1     = 1.704d0
   !
   b1   = force(1)
   b2   = force(2)
   g1   = force(3)
   g2   = force(4)
   !
   rhh=sqrt(r12**2+r32**2-2.d0*r12*r32*cos(alpha))
   vhh=b1*exp(-g1*rhh)+b2*exp(-g2*rhh**2)
   !
   !th1 = 0.5d0*( 1.0d0-tanh( 5.0*( r12-0.0d0 ) ) )
   !th3 = 0.5d0*( 1.0d0-tanh( 5.0*( r32-0.0d0 ) ) )
   !
   th1 = 0.5d0*( 1.0d0-tanh( 2.0*( r12-0.0d0 ) ) )
   th3 = 0.5d0*( 1.0d0-tanh( 2.0*( r32-0.0d0 ) ) )
   !
   !vhh = vhh +(200000.d0*(alpha-alphae)**2+1e5)*th1/r12**12+(200000.d0*(alpha-alphae)**2+1e5)*th3/r32**12
   !
   !write(6,"('rhh,vhh = ',2f20.8)") rhh,vhh
   !
   ! calculate potential energy function values
   !
   y1=1.0d+00-exp(-aa1*(r12-re12))
   y2=1.0d+00-exp(-aa1*(r32-re12))
   !
   y3=(cos(alpha)-cos(alphae)) ! *exp(-1.0*(alpha-alphae)**2)
   !
   v4 = 0 ; v5 = 0 ; v6 = 0 ; v7 = 0 ; v8 = 0
   !
   !write(6,"('y1,y2,y3 = ',3f20.8)") y1,y2,y3
   !
 v0 = force(5)*y1**0*y2**0*y3**0
 v1 = force(6)*y1**0*y2**0*y3**1&
    + force(7)*y1**1*y2**0*y3**0&
    + force(7)*y1**0*y2**1*y3**0
 v2 = force(8)*y1**0*y2**0*y3**2&
    + force(9)*y1**1*y2**0*y3**1&
    + force(9)*y1**0*y2**1*y3**1&
    + force(10)*y1**1*y2**1*y3**0&
    + force(11)*y1**2*y2**0*y3**0&
    + force(11)*y1**0*y2**2*y3**0
 v3 = force(12)*y1**0*y2**0*y3**3&
    + force(13)*y1**1*y2**0*y3**2&
    + force(13)*y1**0*y2**1*y3**2&
    + force(14)*y1**1*y2**1*y3**1&
    + force(15)*y1**2*y2**0*y3**1&
    + force(15)*y1**0*y2**2*y3**1&
    + force(16)*y1**2*y2**1*y3**0&
    + force(16)*y1**1*y2**2*y3**0&
    + force(17)*y1**3*y2**0*y3**0&
    + force(17)*y1**0*y2**3*y3**0

 if (N>18) then
  v4 = force(18)*y1**0*y2**0*y3**4&
    + force(19)*y1**1*y2**0*y3**3&
    + force(19)*y1**0*y2**1*y3**3&
    + force(20)*y1**1*y2**1*y3**2&
    + force(21)*y1**2*y2**0*y3**2&
    + force(21)*y1**0*y2**2*y3**2&
    + force(22)*y1**2*y2**1*y3**1&
    + force(22)*y1**1*y2**2*y3**1&
    + force(23)*y1**2*y2**2*y3**0&
    + force(24)*y1**3*y2**0*y3**1&
    + force(24)*y1**0*y2**3*y3**1&
    + force(25)*y1**3*y2**1*y3**0&
    + force(25)*y1**1*y2**3*y3**0&
    + force(26)*y1**4*y2**0*y3**0&
    + force(26)*y1**0*y2**4*y3**0
endif

 if (N>26) then
  v5 = force(27)*y1**0*y2**0*y3**5&
    + force(28)*y1**1*y2**0*y3**4&
    + force(28)*y1**0*y2**1*y3**4&
    + force(29)*y1**1*y2**1*y3**3&
    + force(30)*y1**2*y2**0*y3**3&
    + force(30)*y1**0*y2**2*y3**3&
    + force(31)*y1**2*y2**1*y3**2&
    + force(31)*y1**1*y2**2*y3**2&
    + force(32)*y1**2*y2**2*y3**1&
    + force(33)*y1**3*y2**0*y3**2&
    + force(33)*y1**0*y2**3*y3**2&
    + force(34)*y1**3*y2**1*y3**1&
    + force(34)*y1**1*y2**3*y3**1&
    + force(35)*y1**3*y2**2*y3**0&
    + force(35)*y1**2*y2**3*y3**0&
    + force(36)*y1**4*y2**0*y3**1&
    + force(36)*y1**0*y2**4*y3**1&
    + force(37)*y1**4*y2**1*y3**0&
    + force(37)*y1**1*y2**4*y3**0&
    + force(38)*y1**5*y2**0*y3**0&
    + force(38)*y1**0*y2**5*y3**0
endif

 if (N>38) then
  v6 = force(39)*y1**0*y2**0*y3**6&
    + force(40)*y1**1*y2**0*y3**5&
    + force(40)*y1**0*y2**1*y3**5&
    + force(41)*y1**1*y2**1*y3**4&
    + force(42)*y1**2*y2**0*y3**4&
    + force(42)*y1**0*y2**2*y3**4&
    + force(43)*y1**2*y2**1*y3**3&
    + force(43)*y1**1*y2**2*y3**3&
    + force(44)*y1**2*y2**2*y3**2&
    + force(45)*y1**3*y2**0*y3**3&
    + force(45)*y1**0*y2**3*y3**3&
    + force(46)*y1**3*y2**1*y3**2&
    + force(46)*y1**1*y2**3*y3**2&
    + force(47)*y1**3*y2**2*y3**1&
    + force(47)*y1**2*y2**3*y3**1&
    + force(48)*y1**3*y2**3*y3**0&
    + force(49)*y1**4*y2**0*y3**2&
    + force(49)*y1**0*y2**4*y3**2&
    + force(50)*y1**4*y2**1*y3**1&
    + force(50)*y1**1*y2**4*y3**1&
    + force(51)*y1**4*y2**2*y3**0&
    + force(51)*y1**2*y2**4*y3**0&
    + force(52)*y1**5*y2**0*y3**1&
    + force(52)*y1**0*y2**5*y3**1&
    + force(53)*y1**5*y2**1*y3**0&
    + force(53)*y1**1*y2**5*y3**0&
    + force(54)*y1**6*y2**0*y3**0&
    + force(54)*y1**0*y2**6*y3**0
 endif

 if (N>54) then
 v7 = force(55)*y1**0*y2**0*y3**7&
    + force(56)*y1**1*y2**0*y3**6&
    + force(56)*y1**0*y2**1*y3**6&
    + force(57)*y1**1*y2**1*y3**5&
    + force(58)*y1**2*y2**0*y3**5&
    + force(58)*y1**0*y2**2*y3**5&
    + force(59)*y1**2*y2**1*y3**4&
    + force(59)*y1**1*y2**2*y3**4&
    + force(60)*y1**2*y2**2*y3**3&
    + force(61)*y1**3*y2**0*y3**4&
    + force(61)*y1**0*y2**3*y3**4&
    + force(62)*y1**3*y2**1*y3**3&
    + force(62)*y1**1*y2**3*y3**3&
    + force(63)*y1**3*y2**2*y3**2&
    + force(63)*y1**2*y2**3*y3**2&
    + force(64)*y1**3*y2**3*y3**1&
    + force(65)*y1**4*y2**0*y3**3&
    + force(65)*y1**0*y2**4*y3**3&
    + force(66)*y1**4*y2**1*y3**2&
    + force(66)*y1**1*y2**4*y3**2&
    + force(67)*y1**4*y2**2*y3**1&
    + force(67)*y1**2*y2**4*y3**1&
    + force(68)*y1**4*y2**3*y3**0&
    + force(68)*y1**3*y2**4*y3**0&
    + force(69)*y1**5*y2**0*y3**2&
    + force(69)*y1**0*y2**5*y3**2&
    + force(70)*y1**5*y2**1*y3**1&
    + force(70)*y1**1*y2**5*y3**1&
    + force(71)*y1**5*y2**2*y3**0&
    + force(71)*y1**2*y2**5*y3**0&
    + force(72)*y1**6*y2**0*y3**1&
    + force(72)*y1**0*y2**6*y3**1&
    + force(73)*y1**6*y2**1*y3**0&
    + force(73)*y1**1*y2**6*y3**0&
    + force(74)*y1**7*y2**0*y3**0&
    + force(74)*y1**0*y2**7*y3**0
 endif

 if (N>74) then
 v8 = force(75)*y1**0*y2**0*y3**8&
    + force(76)*y1**1*y2**0*y3**7&
    + force(76)*y1**0*y2**1*y3**7&
    + force(77)*y1**1*y2**1*y3**6&
    + force(78)*y1**2*y2**0*y3**6&
    + force(78)*y1**0*y2**2*y3**6&
    + force(79)*y1**2*y2**1*y3**5&
    + force(79)*y1**1*y2**2*y3**5&
    + force(80)*y1**2*y2**2*y3**4&
    + force(81)*y1**3*y2**0*y3**5&
    + force(81)*y1**0*y2**3*y3**5&
    + force(82)*y1**3*y2**1*y3**4&
    + force(82)*y1**1*y2**3*y3**4&
    + force(83)*y1**3*y2**2*y3**3&
    + force(83)*y1**2*y2**3*y3**3&
    + force(84)*y1**3*y2**3*y3**2&
    + force(85)*y1**4*y2**0*y3**4&
    + force(85)*y1**0*y2**4*y3**4&
    + force(86)*y1**4*y2**1*y3**3&
    + force(86)*y1**1*y2**4*y3**3&
    + force(87)*y1**4*y2**2*y3**2&
    + force(87)*y1**2*y2**4*y3**2&
    + force(88)*y1**4*y2**3*y3**1&
    + force(88)*y1**3*y2**4*y3**1&
    + force(89)*y1**4*y2**4*y3**0&
    + force(90)*y1**5*y2**0*y3**3&
    + force(90)*y1**0*y2**5*y3**3&
    + force(91)*y1**5*y2**1*y3**2&
    + force(91)*y1**1*y2**5*y3**2&
    + force(92)*y1**5*y2**2*y3**1&
    + force(92)*y1**2*y2**5*y3**1&
    + force(93)*y1**5*y2**3*y3**0&
    + force(93)*y1**3*y2**5*y3**0&
    + force(94)*y1**6*y2**0*y3**2&
    + force(94)*y1**0*y2**6*y3**2&
    + force(95)*y1**6*y2**1*y3**1&
    + force(95)*y1**1*y2**6*y3**1&
    + force(96)*y1**6*y2**2*y3**0&
    + force(96)*y1**2*y2**6*y3**0&
    + force(97)*y1**7*y2**0*y3**1&
    + force(97)*y1**0*y2**7*y3**1&
    + force(98)*y1**7*y2**1*y3**0&
    + force(98)*y1**1*y2**7*y3**0&
    + force(99)*y1**8*y2**0*y3**0&
    + force(99)*y1**0*y2**8*y3**0
endif

     th1 = 0.5d0*( 1.0d0-tanh( 0.00040d0*( v0+v1+v2-45000.0d0 ) ) )

    !th1 = 0.5d0*( 1.0d0-tanh( 0.0001d0*( v0+v1+v2-50000.0d0 ) ) )

    !f=v0+v1+v2+v3+v4+v5+v6+v7+v8+vhh
    !
    f=(v0+v1+v2)+(v3+v4+v5+v6+v7+v8)*th1+vhh
    !
    !if (v0+v1+v2>50000.0) f = v0+v1+v2
    !
    !if (f<0.0) then
    ! write(6,"(2g18.6,2x,g18.6,2x,11g20.8)") r12,r32,theta/3.1415926535897932385*180.d0,f,v0,v1,v2,v3,v4,v5,v6,v7,v8,vhh
    !endif

end subroutine poten


! examples/Fortran/random.f90 - Example code for SPRAL_RANDOM package
program random_example
   use spral_random
   implicit none

   integer, parameter :: long = selected_int_kind(18)

   type(random_state) :: state
   integer :: seed

   ! Store initial random seed so we can reuse it later
   seed = random_get_seed(state)

   ! Generate some random values
   write(*,"(a)") "Some random values"
   write(*,"(a,f16.12)") "Sample Unif(-1,1)               = ", &
      random_real(state)
   write(*,"(a,f16.12)") "Sample Unif(0,1)                = ", &
      random_real(state, positive=.true.)
   write(*,"(a,i16)") "Sample Unif(1, ..., 20)         = ", &
      random_integer(state, 20)
   write(*,"(a,i16)") "Sample Unif(1, ..., 20*huge(0)) = ", &
      random_integer(state, 20_long*huge(0))
   write(*,"(a,l16)") "Sample B(1,0.5)                 = ", &
      random_logical(state)

   ! Restore initial seed
   call random_set_seed(state, seed)

   ! Generate the same random values
   write(*,"(/a)") "The same random values again"
   write(*,"(a,f16.12)") "Sample Unif(-1,1)               = ", &
      random_real(state)
   write(*,"(a,f16.12)") "Sample Unif(0,1)                = ", &
      random_real(state, positive=.true.)
   write(*,"(a,i16)") "Sample Unif(1, ..., 20)         = ", &
      random_integer(state, 20)
   write(*,"(a,i16)") "Sample Unif(1, ..., 20*huge(0)) = ", &
      random_integer(state, 20_long*huge(0))
   write(*,"(a,l16)") "Sample B(1,0.5)                 = ", &
      random_logical(state)

end program random_example


      SUBROUTINE vegas(region,ndim,fxn,init,ncall,itmx,nprn,tgral,sd,
     *chi2a)
      INTEGER init,itmx,ncall,ndim,nprn,NDMX,MXDIM
      REAL tgral,chi2a,sd,region(2*ndim),fxn,ALPH,TINY
      PARAMETER (ALPH=1.5,NDMX=50,MXDIM=10,TINY=1.e-30)
      EXTERNAL fxn
CU    USES fxn,ran2,rebin
      INTEGER i,idum,it,j,k,mds,nd,ndo,ng,npg,ia(MXDIM),kg(MXDIM)
      REAL calls,dv2g,dxg,f,f2,f2b,fb,rc,ti,tsi,wgt,xjac,xn,xnd,xo,
     *d(NDMX,MXDIM),di(NDMX,MXDIM),dt(MXDIM),dx(MXDIM),r(NDMX),x(MXDIM),
     *xi(NDMX,MXDIM),xin(NDMX),ran2
      DOUBLE PRECISION schi,si,swgt
      COMMON /ranno/ idum
      SAVE
      if(init.le.0)then
        mds=1
        ndo=1
        do 11 j=1,ndim
          xi(1,j)=1.
11      continue
      endif
      if (init.le.1)then
        si=0.
        swgt=0.
        schi=0.
      endif
      if (init.le.2)then
        nd=NDMX
        ng=1
        if(mds.ne.0)then
          ng=(ncall/2.+0.25)**(1./ndim)
          mds=1
          if((2*ng-NDMX).ge.0)then
            mds=-1
            npg=ng/NDMX+1
            nd=ng/npg
            ng=npg*nd
          endif
        endif
        k=ng**ndim
        npg=max(ncall/k,2)
        calls=float(npg)*float(k)
        dxg=1./ng
        dv2g=(calls*dxg**ndim)**2/npg/npg/(npg-1.)
        xnd=nd
        dxg=dxg*xnd
        xjac=1./calls
        do 12 j=1,ndim
          dx(j)=region(j+ndim)-region(j)
          xjac=xjac*dx(j)
12      continue
        if(nd.ne.ndo)then
          do 13 i=1,max(nd,ndo)
            r(i)=1.
13        continue
          do 14 j=1,ndim
            call rebin(ndo/xnd,nd,r,xin,xi(1,j))
14        continue
          ndo=nd
        endif
        if(nprn.ge.0) write(*,200) ndim,calls,it,itmx,nprn,ALPH,mds,nd,
     *(j,region(j),j,region(j+ndim),j=1,ndim)
      endif
      do 28 it=1,itmx
        ti=0.
        tsi=0.
        do 16 j=1,ndim
          kg(j)=1
          do 15 i=1,nd
            d(i,j)=0.
            di(i,j)=0.
15        continue
16      continue
10      continue
          fb=0.
          f2b=0.
          do 19 k=1,npg
            wgt=xjac
            do 17 j=1,ndim
              xn=(kg(j)-ran2(idum))*dxg+1.
              ia(j)=max(min(int(xn),NDMX),1)
              if(ia(j).gt.1)then
                xo=xi(ia(j),j)-xi(ia(j)-1,j)
                rc=xi(ia(j)-1,j)+(xn-ia(j))*xo
              else
                xo=xi(ia(j),j)
                rc=(xn-ia(j))*xo
              endif
              x(j)=region(j)+rc*dx(j)
              wgt=wgt*xo*xnd
17          continue
            f=wgt*fxn(x,wgt)
            f2=f*f
            fb=fb+f
            f2b=f2b+f2
            do 18 j=1,ndim
              di(ia(j),j)=di(ia(j),j)+f
              if(mds.ge.0) d(ia(j),j)=d(ia(j),j)+f2
18          continue
19        continue
          f2b=sqrt(f2b*npg)
          f2b=(f2b-fb)*(f2b+fb)
          if (f2b.le.0.) f2b=TINY
          ti=ti+fb
          tsi=tsi+f2b
          if(mds.lt.0)then
            do 21 j=1,ndim
              d(ia(j),j)=d(ia(j),j)+f2b
21          continue
          endif
        do 22 k=ndim,1,-1
          kg(k)=mod(kg(k),ng)+1
          if(kg(k).ne.1) goto 10
22      continue
        tsi=tsi*dv2g
        wgt=1./tsi
        si=si+dble(wgt)*dble(ti)
        schi=schi+dble(wgt)*dble(ti)**2
        swgt=swgt+dble(wgt)
        tgral=si/swgt
        chi2a=max((schi-si*tgral)/(it-.99d0),0.d0)
        sd=sqrt(1./swgt)
        tsi=sqrt(tsi)
        if(nprn.ge.0)then
          write(*,201) it,ti,tsi,tgral,sd,chi2a
          if(nprn.ne.0)then
            do 23 j=1,ndim
              write(*,202) j,(xi(i,j),di(i,j),i=1+nprn/2,nd,nprn)
23          continue
          endif
        endif
        do 25 j=1,ndim
          xo=d(1,j)
          xn=d(2,j)
          d(1,j)=(xo+xn)/2.
          dt(j)=d(1,j)
          do 24 i=2,nd-1
            rc=xo+xn
            xo=xn
            xn=d(i+1,j)
            d(i,j)=(rc+xn)/3.
            dt(j)=dt(j)+d(i,j)
24        continue
          d(nd,j)=(xo+xn)/2.
          dt(j)=dt(j)+d(nd,j)
25      continue
        do 27 j=1,ndim
          rc=0.
          do 26 i=1,nd
            if(d(i,j).lt.TINY) d(i,j)=TINY
            r(i)=((1.-d(i,j)/dt(j))/(log(dt(j))-log(d(i,j))))**ALPH
            rc=rc+r(i)
26        continue
          call rebin(rc/xnd,nd,r,xin,xi(1,j))
27      continue
28    continue
      return
200   FORMAT(/' input parameters for vegas:  ndim=',i3,'  ncall=',
     *f8.0/28x,'  it=',i5,'  itmx=',i5/28x,'  nprn=',i3,'  alph=',
     *f5.2/28x,'  mds=',i3,'   nd=',i4/(30x,'xl(',i2,')= ',g11.4,' xu(',
     *i2,')= ',g11.4))
201   FORMAT(/' iteration no.',I3,': ','integral =',g14.7,'+/- ',g9.2/
     *' all iterations:   integral =',g14.7,'+/- ',g9.2,
     *' chi**2/it''n =',g9.2)
202   FORMAT(/' data for axis ',I2/'    X       delta i       ',
     *'   x       delta i       ','    x       delta i       ',/(1x,
     *f7.5,1x,g11.4,5x,f7.5,1x,g11.4,5x,f7.5,1x,g11.4))
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/vegas.for


      program DRCGAM
c>> 2001-05-22 DRCGAM Krogh Minor change for making .f90 version.
c>> 1996-06-14 DRCGAM Krogh Changes for C conversion.
c>> 1994-08-17 CLL
c>> 1991-10-18 Demo driver for CGAM
c     ------------------------------------------------------------------
c--   D version uses DRZGAM, ZGAM
c--   S version uses DRCGAM, CGAM
c     ------------------------------------------------------------------
      real ARG(2),GAM(2),LGAM(2), X(2,8)
      real ERR0, ERR1
      integer I, J
      data ( ( X(I,J),I=1,2 ), J=1,8 ) /
     * 1.0E0,0.0E0, 1.0E0,0.5E0, 1.5E0,0.0E0, 1.5E0,0.5E0,
     * 0.0E0,0.5E0, -1.5E0,0.5E0,  -1.5E0,0.0E0,  -1.5E0,-0.5E0 /
c     ------------------------------------------------------------------
      print '(5x,''X          GAMMA        Err Est'', 11x,
     * ''LGAMA         Err Est'')'
      do 10 J = 1,8
        ARG(1) = X(1,J)
        ARG(2) = X(2,J)
        call CGAM (ARG,GAM,ERR1,1)
        call CGAM (ARG,LGAM,ERR0,0)
        print
     *  '(1x,f5.1,g20.10,g10.2,g22.10,g10.2/1x,f5.1,g20.10,g32.10/)',
     *        ARG(1),GAM(1),ERR1, LGAM(1), ERR0,
     *        ARG(2),GAM(2),      LGAM(2)
  10  continue
      end


      subroutine gnrfft(ar,nlen,direct,norm)
!
!-------------------------------------------------------------------------------
! This is the routine that is called by SIOSEIS to perform the fft of a real tim
! series. This is a glue routine that defines a common call interface between
! SIOSEIS and FFT routine that have been optimized for different machines.
!
! This version is the general version and uses the simple fft pair & scram
! to perform transform of a real time series.
!
!     integer nlen      The length of the input real time series. A power of two
      real    ar(nlen)
!                       The array containing the time series/DFT trace. In
!                       frequency domain the (real) Nyquist frequency component
!                       is expect to be packed at ar(2) after the zero frequency
!                       component at ar(1). All other frequency components are
!                       as expected i.e. real at ar(2i), imag at ar(2i+1)
      logical direct
!                       Direction of FFT.
!                       = TRUE  forward  FFT time -> frequency.
!                       = FALSE inverse FFT frequency -> time.
!                         sign convention is exp(+iwt) for forward transform
!                                            exp(-iwt) for inverse transform
      logical    norm
!                      = TRUE  normalize the output FFT by 1/nlen
!                      = FALSE no normalization.
!-------------------------------------------------------------------------------
!
!
      integer pow2
!
      np = pow2(nlen) - 1
      if(direct) then                                                   ! forward FFT
        call fftfwd(ar,np)                                              ! A +ve exponent
!        call fftinv(ar,np)
        call scram(ar,nlen/2,+1,.FALSE.)
      else
        call scram(ar,nlen/2,-1,.TRUE.)
        call fftinv(ar,np)
!        call fftfwd(ar,np)
      endif
      if (norm) then
        rlen = float(nlen/2)
        do i = 1, nlen
  10    ar(i) = ar(i)/rlen
        enddo
      endif
      return
      end
!
!
      subroutine scram(a,n,isgn,inv)
!---------------------------------------------------------------------------
!    This routine enables the DFT of a real time series of length 2n to
! be recoverd from the DFT of the sames series when it is treated as a complex
! time series of length n.
!
!    On the forward transform the elements real series of 2n are packed
! sequentially into the real & imaginary parts of the complex array. i.e.
! the even elements (starting at 0) are packed into the real parts & the
! odd elements into the imaginary parts. The FFT of this complex series
! is not the same as the FFT of the real series; the output must be
! processed further to recover the correct positive frequency values. This
! is the job of scram.
!
!   On inverse transform the positive frequency components must be repacked
! prior to being passed to a complex inverse FFT if the resulting output is
! be a real time series.
!
!   For the forward transform, this routine returns the Nyquist frequency
! component packed into the imaginary part of the zero frequency component.
! It expects the Nyquist frequency component packed here for the inverse
! transfrom.
!
      complex a(0:n-1)
!                  The array to be transformed
!     Integer n    The length of the complex arrray
      integer isgn
!                   The sign of the current transform
      logical inv
!                 = TRUE  this is an inverse transform. The frequency
!                         components are being packed prior to DFT
!                 = FALSE this is a forward transform. The positive
!                         frequency components are being upacked after
!                         a DFT.
! Modifications:
!     10/20/88 ( Added conjg to atem a(n-i)= )
!
! Last Modified
!     14/3/89 Changed to single precision for CRAY compatibility
!--------------------------------------------------------------------------
!
      parameter (pi = 3.1415926535)
      integer jsgn
      real    rexp, iexp
      real    rphas, iphas, rtem
      real    rtems, items
      complex atem, btem
      complex yi
!
      nby2 = n/2
      jsgn = sign(1,isgn)
      rtem = pi / float(n)
      rexp =  cos(rtem)
      iexp =  sin(jsgn*rtem)
      rphas = 1.0
      iphas = 0.0
      if (inv) then
        yi = cmplx(0.,-0.5)
      else
!      yi   = jsgn * cmplx(0., 0.5)
        yi   = cmplx(0., 0.5)
      endif
!
      do 10 i = 1, nby2
      rtem   = rexp * rphas - iexp * iphas
      iphas  = rexp * iphas + iexp * rphas
      atem   = 0.5 * (a(i) + conjg(a(n-i)))
      btem   = yi * cmplx(rtem, iphas) * ( a(i) - conjg( a(n-i) ) )
      a(i)   = atem - btem
      a(n-i) = atem + conjg(btem)
      a(n-i) = conjg(atem) + conjg(btem)
      rphas  = rtem
   10 continue
!
!.. Assume that the Nyquist frequency is packed/wanted in the imaginary
!    part of the zero frequency component
      rtems = real(a(0))
      items = aimag(a(0))
      a(0)  = cmplx(rtems + items, rtems - items)
      if (inv) a(0) = 0.5 * a(0)
      return
      end


module constants

  !--------------------------------------------------------------------!
  !         just the library of constants used in the TB tools         !
  !--------------------------------------------------------------------!

  implicit none

  !---------------------- OS dependent constants ----------------------!
  ! CURDIR    : OS dependent symbol for the current directory          !
  ! DIRSEP    : OS dependent symbol for the directory deparator        !
  !--------------------------------------------------------------------!

  character, parameter :: CURDIR = '.'
  character, parameter :: DIRSEP = '/'

  !---------------------- fortran 90 type kinds -----------------------!
  ! DP    : double precision kind                                      !
  !--------------------------------------------------------------------!

  integer,   parameter :: DP = kind(1.0d0)

  !----------------- mathematical/numerical constants -----------------!
  ! see below for explanations                                         !
  !--------------------------------------------------------------------!

  double precision, parameter :: PI          = 3.141592653589793d0
  double precision, parameter :: SQRT_PI     = 1.772453850905516d0
  double precision, parameter :: PI_INV      = 1.0d0/PI
  double precision, parameter :: SQRT_PI_INV = 1.0d0/SQRT_PI
  double precision, parameter :: PI2         = 2.0d0*PI
  double precision, parameter :: PI2_INV     = 1.0d0/PI2
  double precision, parameter :: SQRT2       = 1.4142135623731d0
  double precision, parameter :: SQRT2_INV   = 1.0d0/SQRT2

  !------------------------- unit conversion --------------------------!

  double precision, parameter :: eV2Ha       =  0.0367493089d0
  double precision, parameter :: Ha2eV       = 27.2113961d0
  double precision, parameter :: Ry2Ha       =  0.5d0
  double precision, parameter :: Ha2Ry       =  2.0d0
  double precision, parameter :: Ang2Bohr    =  1.88972598501d0

end module constants


! This test was created from ../../exercism/problem-specifications/exercises/matrix/canonical-data.json
! version: 1.3.0
!

program matrix_test_main

  use TesterMain
  use matrix

  implicit none

  ! Test 1: extract row from one number matrix
  !!call assert_equal_int_arr(1, row(1, 1), "extract row from one number matrix")
  ! Test 2: can extract row
  call assert_equal((/3, 4/), row( (/"1, 2", "3, 4"/), (/ 2, 2 /), 2), "can extract row")
  ! Test 3: extract row where numbers have different widths
  call assert_equal((/10, 20/), row( (/"1, 2  ", "10, 20"/), (/ 2, 2 /), 2), &
    & "extract row where numbers have different widths")
  ! Test 4: can extract row from non-square matrix with no corresponding column
  call assert_equal((/8, 7, 6/), row( &
    & (/"1, 2, 3", &
    &   "4, 5, 6", &
    &   "7, 8, 9", &
    &   "8, 7, 6"/), (/ 3, 4 /), 4), &
    &  "can extract row from non-square matrix with no corresponding column")
  ! Test 5: extract column from one number matrix
  !!call assert_equal_int_arr(1, column(1, 1), "extract column from one number matrix")
  ! Test 6: can extract column
  call assert_equal((/3, 6, 9/), column( &
    & (/"1, 2, 3", &
    &   "4, 5, 6", &
    &   "7, 8, 9"/), (/3, 3/), 3), &
    & "can extract column")
  ! Test 7: can extract column from non-square matrix with no corresponding row
  call assert_equal((/4, 8, 6/), column( &
    & (/"1, 2, 3, 4", &
    &   "5, 6, 7, 8", &
    &   "9, 8, 7, 6"/), (/4,3/), 4), &
    & "can extract column from non-square matrix with no corresponding row")
  ! Test 8: extract column where numbers have different widths
  call assert_equal((/1903, 3, 479/), column( &
    &  (/"89, 1903, 3", &
    &    "18, 3, 1   ", &
    &    "9, 479, 800"/), (/3,3/), 2), &
    & "extract column where numbers have different widths")

  call test_report()

end program


	SUBROUTINE ST_C2R  ( string, nexp, rarr, num, iret )
C************************************************************************
C* ST_C2R								*
C*									*
C* This subroutine converts a string into an array of real numbers. 	*
C* The numbers may be separated by any non-alphanumeric character	*
C* except a period (.), a plus sign (+), a minus sign (-), or an	*
C* asterisk (*).							*
C*									*
C* ST_C2R  ( STRING, NEXP, RARR, NUM, IRET )				*
C*									*
C* Input parameters:                                                   	*
C*	STRING		CHAR*		String 				*
C*	NEXP		INTEGER		Maximum number of reals		*
C*									*
C* Output parameters:							*
C*	RARR (NUM)	REAL		Converted real array		*
C*	NUM		INTEGER		Number of converted reals	*
C*	IRET		INTEGER		Return code  			*
C*				 	  1 = more than NEXP reals 	*
C*				 	  0 = normal return		*
C*					 -1 = invalid string 		*
C*					 -2 = conversion error		*
C** 									*
C* Log:									*
C* I. Graffman/CSC	 7/82	STR_CHRL				*
C* I. Graffman/RDS	 2/84	Use new GEMPAK routines			*
C* M. desJardins/GSFC	 6/88	Documentation				*
C* L. Sager/NCEP	 2/96   Increased size of strbuf		*
C* T. Piper/GSC		11/98	Updated prolog				*
C************************************************************************
	CHARACTER*(*)	string
	REAL		rarr (*)
C*
	CHARACTER	strbuf*160
C------------------------------------------------------------------------
	num    = 0
	iret   = 0
	strbuf = string
C
C*	Remove separators.
C
	CALL ST_RNAN  ( strbuf, strbuf, lens, iret )
	IF  ( lens .le. 0 )  THEN
	    iret = -1
	    RETURN
	END IF
C
C*	Set up pointers.
C
	ip = 1
	ie = 1
C
C*	Parse the string.
C
	DO WHILE  ( ip .le. lens )
	    ie = INDEX  ( strbuf (ip:lens), ' ' )
	    IF  ( ie .eq. 0 )  THEN
		ie = lens + 1
	      ELSE
		ie = ie + ip - 1
	    ENDIF
C
C*	    Check that num is not too large.
C
	    IF  ( num .ge. nexp )  THEN
	        iret = 1
	        RETURN
	      ELSE
		num = num + 1
C
C*		Convert.
C
		CALL ST_CRNM  ( strbuf (ip:ie-1), rarr (num), ier )
		IF ( ier .lt. 0 )  iret = -2
		ip = ie + 1
	    END IF
	END DO
C*
	RETURN
	END


program test
  integer :: n= 10
  real(kind=8) :: cfl,cfll
  cfl = 2.0

  cfll=0.1+(n-1.)*cfl/20.0
  print *, cfll
end program test


      REAL FUNCTION FN1(I)
        INTEGER I
        FN1 = I * 2.0
        RETURN
      END FUNCTION FN1

      REAL FUNCTION FN2(A, B)
        REAL A, B
        FN2 = A + B
        RETURN
      END FUNCTION FN2

      PROGRAM A21
        INCLUDE "omp_lib.h" ! or USE OMP_LIB
        INTEGER ISYNC(256)
        REAL WORK(256)
        REAL RESULT(256)
        INTEGER IAM, NEIGHBOR
!$OMP PARALLEL PRIVATE(IAM, NEIGHBOR) SHARED(WORK, ISYNC)
        IAM = OMP_GET_THREAD_NUM() + 1
        ISYNC(IAM) = 0
!$OMP BARRIER
C Do computation into my portion of work array
        WORK(IAM) = FN1(IAM)
C Announce that I am done with my work.
C The first flush ensures that my work is made visible before
C synch. The second flush ensures that synch is made visible.
!$OMP FLUSH(WORK,ISYNC)
        ISYNC(IAM) = 1
!$OMP FLUSH(ISYNC)
C Wait until neighbor is done. The first flush ensures that
C synch is read from memory, rather than from the temporary
C view of memory. The second flush ensures that work is read
C from memory, and is done so after the while loop exits.
        IF (IAM .EQ. 1) THEN
        NEIGHBOR = OMP_GET_NUM_THREADS()
        ELSE
        NEIGHBOR = IAM - 1
        ENDIF
        DO WHILE (ISYNC(NEIGHBOR) .EQ. 0)
!$OMP FLUSH(ISYNC)
        END DO
!$OMP FLUSH(WORK, ISYNC)
        RESULT(IAM) = FN2(WORK(NEIGHBOR), WORK(IAM))
!$OMP END PARALLEL
      END PROGRAM A21


      SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
     $                   LDZ, WORK, LWORK, INFO )
*
*  -- LAPACK driver routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
      CHARACTER          COMPZ, JOB
*     ..
*     .. Array Arguments ..
      REAL               H( LDH, * ), WI( * ), WORK( * ), WR( * ),
     $                   Z( LDZ, * )
*     ..
*     Purpose
*     =======
*
*     SHSEQR computes the eigenvalues of a Hessenberg matrix H
*     and, optionally, the matrices T and Z from the Schur decomposition
*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the
*     Schur form), and Z is the orthogonal matrix of Schur vectors.
*
*     Optionally Z may be postmultiplied into an input orthogonal
*     matrix Q so that this routine can give the Schur factorization
*     of a matrix A which has been reduced to the Hessenberg form H
*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
*     Arguments
*     =========
*
*     JOB   (input) CHARACTER*1
*           = 'E':  compute eigenvalues only;
*           = 'S':  compute eigenvalues and the Schur form T.
*
*     COMPZ (input) CHARACTER*1
*           = 'N':  no Schur vectors are computed;
*           = 'I':  Z is initialized to the unit matrix and the matrix Z
*                   of Schur vectors of H is returned;
*           = 'V':  Z must contain an orthogonal matrix Q on entry, and
*                   the product Q*Z is returned.
*
*     N     (input) INTEGER
*           The order of the matrix H.  N .GE. 0.
*
*     ILO   (input) INTEGER
*     IHI   (input) INTEGER
*           It is assumed that H is already upper triangular in rows
*           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*           set by a previous call to SGEBAL, and then passed to SGEHRD
*           when the matrix output by SGEBAL is reduced to Hessenberg
*           form. Otherwise ILO and IHI should be set to 1 and N
*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
*           If N = 0, then ILO = 1 and IHI = 0.
*
*     H     (input/output) REAL array, dimension (LDH,N)
*           On entry, the upper Hessenberg matrix H.
*           On exit, if INFO = 0 and JOB = 'S', then H contains the
*           upper quasi-triangular matrix T from the Schur decomposition
*           (the Schur form); 2-by-2 diagonal blocks (corresponding to
*           complex conjugate pairs of eigenvalues) are returned in
*           standard form, with H(i,i) = H(i+1,i+1) and
*           H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the
*           contents of H are unspecified on exit.  (The output value of
*           H when INFO.GT.0 is given under the description of INFO
*           below.)
*
*           Unlike earlier versions of SHSEQR, this subroutine may
*           explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
*           or j = IHI+1, IHI+2, ... N.
*
*     LDH   (input) INTEGER
*           The leading dimension of the array H. LDH .GE. max(1,N).
*
*     WR    (output) REAL array, dimension (N)
*     WI    (output) REAL array, dimension (N)
*           The real and imaginary parts, respectively, of the computed
*           eigenvalues. If two eigenvalues are computed as a complex
*           conjugate pair, they are stored in consecutive elements of
*           WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and
*           WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in
*           the same order as on the diagonal of the Schur form returned
*           in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
*           diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
*           WI(i+1) = -WI(i).
*
*     Z     (input/output) REAL array, dimension (LDZ,N)
*           If COMPZ = 'N', Z is not referenced.
*           If COMPZ = 'I', on entry Z need not be set and on exit,
*           if INFO = 0, Z contains the orthogonal matrix Z of the Schur
*           vectors of H.  If COMPZ = 'V', on entry Z must contain an
*           N-by-N matrix Q, which is assumed to be equal to the unit
*           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
*           if INFO = 0, Z contains Q*Z.
*           Normally Q is the orthogonal matrix generated by SORGHR
*           after the call to SGEHRD which formed the Hessenberg matrix
*           H. (The output value of Z when INFO.GT.0 is given under
*           the description of INFO below.)
*
*     LDZ   (input) INTEGER
*           The leading dimension of the array Z.  if COMPZ = 'I' or
*           COMPZ = 'V', then LDZ.GE.MAX(1,N).  Otherwize, LDZ.GE.1.
*
*     WORK  (workspace/output) REAL array, dimension (LWORK)
*           On exit, if INFO = 0, WORK(1) returns an estimate of
*           the optimal value for LWORK.
*
*     LWORK (input) INTEGER
*           The dimension of the array WORK.  LWORK .GE. max(1,N)
*           is sufficient, but LWORK typically as large as 6*N may
*           be required for optimal performance.  A workspace query
*           to determine the optimal workspace size is recommended.
*
*           If LWORK = -1, then SHSEQR does a workspace query.
*           In this case, SHSEQR checks the input parameters and
*           estimates the optimal workspace size for the given
*           values of N, ILO and IHI.  The estimate is returned
*           in WORK(1).  No error message related to LWORK is
*           issued by XERBLA.  Neither H nor Z are accessed.
*
*
*     INFO  (output) INTEGER
*             =  0:  successful exit
*           .LT. 0:  if INFO = -i, the i-th argument had an illegal
*                    value
*           .GT. 0:  if INFO = i, SHSEQR failed to compute all of
*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
*                and WI contain those eigenvalues which have been
*                successfully computed.  (Failures are rare.)
*
*                If INFO .GT. 0 and JOB = 'E', then on exit, the
*                remaining unconverged eigenvalues are the eigen-
*                values of the upper Hessenberg matrix rows and
*                columns ILO through INFO of the final, output
*                value of H.
*
*                If INFO .GT. 0 and JOB   = 'S', then on exit
*
*           (*)  (initial value of H)*U  = U*(final value of H)
*
*                where U is an orthogonal matrix.  The final
*                value of H is upper Hessenberg and quasi-triangular
*                in rows and columns INFO+1 through IHI.
*
*                If INFO .GT. 0 and COMPZ = 'V', then on exit
*
*                  (final value of Z)  =  (initial value of Z)*U
*
*                where U is the orthogonal matrix in (*) (regard-
*                less of the value of JOB.)
*
*                If INFO .GT. 0 and COMPZ = 'I', then on exit
*                      (final value of Z)  = U
*                where U is the orthogonal matrix in (*) (regard-
*                less of the value of JOB.)
*
*                If INFO .GT. 0 and COMPZ = 'N', then Z is not
*                accessed.
*
*     ================================================================
*             Default values supplied by
*             ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
*             It is suggested that these defaults be adjusted in order
*             to attain best performance in each particular
*             computational environment.
*
*            ISPEC=1:  The SLAHQR vs SLAQR0 crossover point.
*                      Default: 75. (Must be at least 11.)
*
*            ISPEC=2:  Recommended deflation window size.
*                      This depends on ILO, IHI and NS.  NS is the
*                      number of simultaneous shifts returned
*                      by ILAENV(ISPEC=4).  (See ISPEC=4 below.)
*                      The default for (IHI-ILO+1).LE.500 is NS.
*                      The default for (IHI-ILO+1).GT.500 is 3*NS/2.
*
*            ISPEC=3:  Nibble crossover point. (See ILAENV for
*                      details.)  Default: 14% of deflation window
*                      size.
*
*            ISPEC=4:  Number of simultaneous shifts, NS, in
*                      a multi-shift QR iteration.
*
*                      If IHI-ILO+1 is ...
*
*                      greater than      ...but less    ... the
*                      or equal to ...      than        default is
*
*                           1               30          NS -   2(+)
*                          30               60          NS -   4(+)
*                          60              150          NS =  10(+)
*                         150              590          NS =  **
*                         590             3000          NS =  64
*                        3000             6000          NS = 128
*                        6000             infinity      NS = 256
*
*                  (+)  By default some or all matrices of this order
*                       are passed to the implicit double shift routine
*                       SLAHQR and NS is ignored.  See ISPEC=1 above
*                       and comments in IPARM for details.
*
*                       The asterisks (**) indicate an ad-hoc
*                       function of N increasing from 10 to 64.
*
*            ISPEC=5:  Select structured matrix multiply.
*                      (See ILAENV for details.) Default: 3.
*
*     ================================================================
*     Based on contributions by
*        Karen Braman and Ralph Byers, Department of Mathematics,
*        University of Kansas, USA
*
*     ================================================================
*     References:
*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*       929--947, 2002.
*
*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
*       of Matrix Analysis, volume 23, pages 948--973, 2002.
*
*     ================================================================
*     .. Parameters ..
*
*     ==== Matrices of order NTINY or smaller must be processed by
*     .    SLAHQR because of insufficient subdiagonal scratch space.
*     .    (This is a hard limit.) ====
*
*     ==== NL allocates some local workspace to help small matrices
*     .    through a rare SLAHQR failure.  NL .GT. NTINY = 11 is
*     .    required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom-
*     .    mended.  (The default value of NMIN is 75.)  Using NL = 49
*     .    allows up to six simultaneous shifts and a 16-by-16
*     .    deflation window.  ====
*
      INTEGER            NTINY
      PARAMETER          ( NTINY = 11 )
      INTEGER            NL
      PARAMETER          ( NL = 49 )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0 )
*     ..
*     .. Local Arrays ..
      REAL               HL( NL, NL ), WORKL( NL )
*     ..
*     .. Local Scalars ..
      INTEGER            I, KBOT, NMIN
      LOGICAL            INITZ, LQUERY, WANTT, WANTZ
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      LOGICAL            LSAME
      EXTERNAL           ILAENV, LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLACPY, SLAHQR, SLAQR0, SLASET, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*
*     ==== Decode and check the input parameters. ====
*
      WANTT = LSAME( JOB, 'S' )
      INITZ = LSAME( COMPZ, 'I' )
      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
      WORK( 1 ) = REAL( MAX( 1, N ) )
      LQUERY = LWORK.EQ.-1
*
      INFO = 0
      IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -5
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
         INFO = -11
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
*
      IF( INFO.NE.0 ) THEN
*
*        ==== Quick return in case of invalid argument. ====
*
         CALL XERBLA( 'SHSEQR', -INFO )
         RETURN
*
      ELSE IF( N.EQ.0 ) THEN
*
*        ==== Quick return in case N = 0; nothing to do. ====
*
         RETURN
*
      ELSE IF( LQUERY ) THEN
*
*        ==== Quick return in case of a workspace query ====
*
         CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
     $                IHI, Z, LDZ, WORK, LWORK, INFO )
*        ==== Ensure reported workspace size is backward-compatible with
*        .    previous LAPACK versions. ====
         WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) )
         RETURN
*
      ELSE
*
*        ==== copy eigenvalues isolated by SGEBAL ====
*
         DO 10 I = 1, ILO - 1
            WR( I ) = H( I, I )
            WI( I ) = ZERO
   10    CONTINUE
         DO 20 I = IHI + 1, N
            WR( I ) = H( I, I )
            WI( I ) = ZERO
   20    CONTINUE
*
*        ==== Initialize Z, if requested ====
*
         IF( INITZ )
     $      CALL SLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
*
*        ==== Quick return if possible ====
*
         IF( ILO.EQ.IHI ) THEN
            WR( ILO ) = H( ILO, ILO )
            WI( ILO ) = ZERO
            RETURN
         END IF
*
*        ==== SLAHQR/SLAQR0 crossover point ====
*
         NMIN = ILAENV( 1, 'SHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO,
     $          IHI, LWORK )
         NMIN = MAX( NTINY, NMIN )
*
*        ==== SLAQR0 for big matrices; SLAHQR for small ones ====
*
         IF( N.GT.NMIN ) THEN
            CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
     $                   IHI, Z, LDZ, WORK, LWORK, INFO )
         ELSE
*
*           ==== Small matrix ====
*
            CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
     $                   IHI, Z, LDZ, INFO )
*
            IF( INFO.GT.0 ) THEN
*
*              ==== A rare SLAHQR failure!  SLAQR0 sometimes succeeds
*              .    when SLAHQR fails. ====
*
               KBOT = INFO
*
               IF( N.GE.NL ) THEN
*
*                 ==== Larger matrices have enough subdiagonal scratch
*                 .    space to call SLAQR0 directly. ====
*
                  CALL SLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR,
     $                         WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
*
               ELSE
*
*                 ==== Tiny matrices don't have enough subdiagonal
*                 .    scratch space to benefit from SLAQR0.  Hence,
*                 .    tiny matrices must be copied into a larger
*                 .    array before calling SLAQR0. ====
*
                  CALL SLACPY( 'A', N, N, H, LDH, HL, NL )
                  HL( N+1, N ) = ZERO
                  CALL SLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
     $                         NL )
                  CALL SLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR,
     $                         WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO )
                  IF( WANTT .OR. INFO.NE.0 )
     $               CALL SLACPY( 'A', N, N, HL, NL, H, LDH )
               END IF
            END IF
         END IF
*
*        ==== Clear out the trash, if necessary. ====
*
         IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
     $      CALL SLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
*
*        ==== Ensure reported workspace size is backward-compatible with
*        .    previous LAPACK versions. ====
*
         WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) )
      END IF
*
*     ==== End of SHSEQR ====
*
      END


!==============================================================================!
  subroutine Vof_Initialization_Plane(mult)
!------------------------------------------------------------------------------!
!   Initialize as vof = 1 all cells beneath the plane given by 3 points        !
!   sorted anticlockwise to the direction of the plane normal                  !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Work_Mod, only: prelim_vof     => r_cell_01,  &
                      min_max_crit_1 => r_cell_02,  &
                      min_max_crit_2 => r_cell_03
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Multiphase_Type),  target :: mult
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type),  pointer :: grid
  real, allocatable         :: p_xyz(:,:)
  integer                   :: c, n, fu
  integer                   :: ee, n_planes
  real                      :: n_xyz(3), v1aux(3), v2aux(3)
  real                      :: res_dummy
  real                      :: dd
!==============================================================================!

  ! First take aliases
  grid => mult % pnt_grid

  prelim_vof = 0.0

  ! Open file to read Plane parameters:
  call File_Mod_Open_File_For_Reading('plane_parameters.dat', fu)

  read (fu,*) n_planes

  if (allocated(p_xyz)) deallocate(p_xyz)
  allocate(p_xyz(n_planes*3,3))

  do ee = 1, n_planes

    ! Taking extrema
    min_max_crit_1(:) =  HUGE
    min_max_crit_2(:) = -HUGE

    read(fu,*) p_xyz(1,:)
    read(fu,*) p_xyz(2,:)
    read(fu,*) p_xyz(3,:)

    v1aux(:) = p_xyz(2,:) - p_xyz(1,:)
    v2aux(:) = p_xyz(3,:) - p_xyz(1,:)

    n_xyz(1) = v1aux(2) * v2aux(3) - v1aux(3) * v2aux(2)
    n_xyz(2) = - (v1aux(1) * v2aux(3) - v1aux(3) * v2aux(1))
    n_xyz(3) = v1aux(1) * v2aux(2) - v1aux(2) * v2aux(1)

    dd = n_xyz(1) * p_xyz(1,1) + n_xyz(2) * p_xyz(1,2) + n_xyz(3) * p_xyz(1,3)

    do c = 1, grid % n_cells
      ! for every node:
      do n = 1, grid % cells_n_nodes(c)

        res_dummy = n_xyz(1) * grid % xn(grid % cells_n(n,c))      &
                  + n_xyz(2) * grid % yn(grid % cells_n(n,c))      &
                  + n_xyz(3) * grid % zn(grid % cells_n(n,c))

        min_max_crit_1(c)= min(res_dummy, min_max_crit_1(c))
        min_max_crit_2(c)= max(res_dummy, min_max_crit_2(c))
      end do
    end do

    ! Simply interpolate linearly
    do c = 1, grid % n_cells
      if (min_max_crit_1(c) < dd .and. min_max_crit_2(c) > dd) then
        prelim_vof(c) = 1.0 - (min_max_crit_2(c) - dd)  &
                      / (min_max_crit_2(c)-min_max_crit_1(c))
      else if (min_max_crit_2(c) <= dd) then
        prelim_vof(c) = 1.0
      end if
    end do

    ! Precision
    do c = 1, grid % n_cells
      mult % vof % n(c) = max(prelim_vof(c),mult % vof % n(c))
    end do

  end do

  close(fu)

  end subroutine


module generic

! Module contains generic subroutines for the casl algorithm
! in a multi-layer aperiodic geometry.

!          *** These should not be modified ***

use parameters
use constants

implicit none

contains

!=======================================================================

subroutine interpol(fp,fe,xp,yp)

! Interpolates the field fp(iy,ix,iz) at a given set of points
! xp(iy,ix,iz), yp(iy,ix,iz) (given in grid units) using
! bi-cubic Lagrange interpolation.

! The interpolated field is written into the array fe.

implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Passed arrays:
double precision:: fp(0:ny,0:nxm1,nz),fe(0:ny,0:nxm1,nz)
double precision:: xp(0:ny,0:nxm1,nz),yp(0:ny,0:nxm1,nz)
 !Local arrays:
double precision:: phix(-1:2),phiy(-1:2)
integer:: ixper(-1:nx+2)
!---------------------------------------------------------------
 !Grid box reference index used below for x periodicity:
ixper(-1)=nxm1
do ix=0,nxm1
  ixper(ix)=ix
enddo
ixper(nx  )=0
ixper(nx+1)=1
ixper(nx+2)=2

do iz=1,nz
  do ix=0,nxm1
    do iy=0,ny
      ix0=int(xp(iy,ix,iz))
       !ix0: the x grid box containing the point
      px0=xp(iy,ix,iz)-dble(ix0)

      pxm=one+px0
      px1=one-px0
      px2=two-px0
      phix(-1)=-f16*px0*px1*px2
      phix( 0)= f12*pxm*px1*px2
      phix( 1)= f12*pxm*px0*px2
      phix( 2)=-f16*pxm*px0*px1

      iy0=min(int(yp(iy,ix,iz)),nym1)
       !iy0: the y grid box containing the point
      py0=yp(iy,ix,iz)-dble(iy0)

      pym=one+py0
      py1=one-py0
      py2=two-py0
      phiy(-1)=-f16*py0*py1*py2
      phiy( 0)= f12*pym*py1*py2
      phiy( 1)= f12*pym*py0*py2
      phiy( 2)=-f16*pym*py0*py1

      fe(iy,ix,iz)=zero
      do jx=-1,2
        ixi=ixper(ix0+jx)
        do jy=-1,2
          iyi=ny-abs(ny-abs(iy0+jy))
          fe(iy,ix,iz)=fe(iy,ix,iz)+fp(iyi,ixi,iz)*phix(jx)*phiy(jy)
        enddo
      enddo
    enddo
  enddo
enddo

return
end subroutine

!=======================================================================

subroutine combine(qq,qc,qs,qd,qavg)

! Combines contour (qc), large scale (qs), and residual (qd) fields
! into qq, ensuring the domain average of qq = qavg in each layer.

implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Define passed arrays:
double precision:: qq(0:ny,0:nxm1,nz),qc(0:ny,0:nxm1,nz)
double precision:: qs(0:ny,0:nxm1,nz),qd(0:ny,0:nxm1,nz)
double precision:: qavg(nz)
 !Define local arrays:
double precision:: wka(0:ny,0:nxm1,nz)

!Define q = F[qs-qc]+qc+qd
!where F is a low pass filter (see subroutine filter)
do iz=1,nz
  do ix=0,nxm1
    do iy=0,ny
      wka(iy,ix,iz)=qs(iy,ix,iz)-qc(iy,ix,iz)
    enddo
  enddo
enddo

call filter(wka,0,2)

do iz=1,nz
  do ix=0,nxm1
    do iy=0,ny
      qq(iy,ix,iz)=wka(iy,ix,iz)+qc(iy,ix,iz)
    enddo
  enddo
enddo

 !Restore domain average:
do iz=1,nz
  call average(qq(0,0,iz),qavg0)
  qqadd=qavg(iz)-qavg0
  do ix=0,nxm1
    do iy=0,ny
      qq(iy,ix,iz)=qq(iy,ix,iz)+qqadd+qd(iy,ix,iz)
    enddo
  enddo
enddo

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

subroutine reset(qc,qs,qd,qavg)

! Resets the gridded fields qs & qd and ensures that <qs> = qavg
! in each layer

implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Define passed arrays:
double precision:: qc(0:ny,0:nxm1,nz),qs(0:ny,0:nxm1,nz),qd(0:ny,0:nxm1,nz)
double precision:: qavg(nz)
 !Define local array:
double precision:: wka(0:ny,0:nxm1,nz)

 !------------------------------------------------------------
 !Reset qs = q = F[qs-qc]+qc+qd, where F is a low pass filter:
do iz=1,nz
  do ix=0,nxm1
    do iy=0,ny
      wka(iy,ix,iz)=qs(iy,ix,iz)-qc(iy,ix,iz)
    enddo
  enddo
enddo

call filter(wka,0,2)

do iz=1,nz
  do ix=0,nxm1
    do iy=0,ny
      qs(iy,ix,iz)=wka(iy,ix,iz)+qc(iy,ix,iz)
    enddo
  enddo
enddo

 !------------------------------------------------------------
 !Reset qd = q-qc-F[q-qc] and restore domain average:
do iz=1,nz
  call average(qs(0,0,iz),qavg0)
  qsadd=qavg(iz)-qavg0
  do ix=0,nxm1
    do iy=0,ny
      qs(iy,ix,iz)=qs(iy,ix,iz)+qsadd+qd(iy,ix,iz)
      qd(iy,ix,iz)=qs(iy,ix,iz)-qc(iy,ix,iz)
      wka(iy,ix,iz)=qd(iy,ix,iz)
    enddo
  enddo
   !Recompute domain average (which evolves because of qd):
  call average(qs(0,0,iz),qavg(iz))
enddo

call filter(wka,0,2)

do iz=1,nz
  do ix=0,nxm1
    do iy=0,ny
      qd(iy,ix,iz)=qd(iy,ix,iz)-wka(iy,ix,iz)
    enddo
  enddo
enddo

return
end subroutine

!=======================================================================

subroutine filter(qq,isym,nrep)

! Performs nrep 1-2-1 filters in each direction to return a
! low pass filtered version of the original array.
! If isym = 0, var is assumed to be symmetric across the boundaries,
! while if isym = 1, var is assumed to be anti-symmetric.

implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Define passed arrays:
double precision:: qq(0:ny,0:nxm1,nz)
 !Define local array:
double precision:: wka(0:ny,0:nxm1)

 !Perform 1-2-1 average nrep times utilising intermediate work array:
if (isym .eq. 0) then
   !The function is symmetric across y boundaries:

  do j=1,nrep
    do iz=1,nz
      do iy=0,ny
        wka(iy,   0)=f12*qq(iy,   0,iz)+f14*(qq(iy,nxm1,iz)+qq(iy,1,iz))
        wka(iy,nxm1)=f12*qq(iy,nxm1,iz)+f14*(qq(iy,nxm2,iz)+qq(iy,0,iz))
      enddo
      do ix=1,nxm2
        do iy=0,ny
          wka(iy,ix)=f12*qq(iy,ix,iz)+f14*(qq(iy,ix-1,iz)+qq(iy,ix+1,iz))
        enddo
      enddo

      do ix=0,nxm1
        qq(0, ix,iz)=f12*(wka(0, ix)+wka(1,   ix))
        do iy=1,nym1
          qq(iy,ix,iz)=f12*wka(iy,ix)+f14*(wka(iy-1,ix)+wka(iy+1,ix))
        enddo
        qq(ny,ix,iz)=f12*(wka(ny,ix)+wka(nym1,ix))
      enddo
    enddo
  enddo

else
   !Function is anti-symmetric across y boundaries:

  do j=1,nrep
    do iz=1,nz
      do iy=0,ny
        wka(iy,   0)=f12*qq(iy,   0,iz)+f14*(qq(iy,nxm1,iz)+qq(iy,1,iz))
        wka(iy,nxm1)=f12*qq(iy,nxm1,iz)+f14*(qq(iy,nxm2,iz)+qq(iy,0,iz))
      enddo
      do ix=1,nxm2
        do iy=0,ny
          wka(iy,ix)=f12*qq(iy,ix,iz)+f14*(qq(iy,ix-1,iz)+qq(iy,ix+1,iz))
        enddo
      enddo

      do ix=0,nxm1
        qq(0, ix,iz)=f12*wka(0, ix)
        do iy=1,nym1
          qq(iy,ix,iz)=f12*wka(iy,ix)+f14*(wka(iy-1,ix)+wka(iy+1,ix))
        enddo
        qq(ny,ix,iz)=f12*wka(ny,ix)
      enddo
    enddo
  enddo

endif

return
end subroutine

!=======================================================================

subroutine average(var,vavg)

! Computes the average value of a 2D field var and returns
! the result in vavg

implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Define passed array:
double precision:: var(0:ny,0:nxm1)

 !Use trapezoidal rule in both directions:
vavg=zero
do ix=0,nxm1
  vavg=vavg+var(0,ix)+var(ny,ix)
enddo
vavg=f12*vavg

do ix=0,nxm1
  do iy=1,nym1
    vavg=vavg+var(iy,ix)
  enddo
enddo

vavg=vavg/dble(nx*ny)

return
end subroutine

!=======================================================================

subroutine l1norm(var,vl1)

! Computes the L1 norm of a 2D field var and returns the result in vl1:
!          vl1 = int_xmin^xmax{int_ymin^ymax{|var| dxdy}}

implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Define passed arrays:
double precision:: var(0:ny,0:nxm1)

 !Use trapezoidal rule in both directions:
vl1=zero
do ix=0,nxm1
  vl1=vl1+abs(var(0,ix))+abs(var(ny,ix))
enddo
vl1=f12*vl1

do ix=0,nxm1
  do iy=1,nym1
    vl1=vl1+abs(var(iy,ix))
  enddo
enddo

vl1=garea*vl1
 !Note: garea is the grid box area, glx*gly

return
end subroutine

!=======================================================================

subroutine l2norm(var,vl2)

! Computes the L2 norm of a 2D field var and returns the result in vl2:
!          vl2 = int_xmin^xmax{int_ymin^ymax{var^2 dxdy}}

implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Define passed arrays:
double precision:: var(0:ny,0:nxm1)

 !Use trapezoidal rule in both directions:
vl2=zero
do ix=0,nxm1
  vl2=vl2+var(0,ix)**2+var(ny,ix)**2
enddo
vl2=f12*vl2

do ix=0,nxm1
  do iy=1,nym1
    vl2=vl2+var(iy,ix)**2
  enddo
enddo

vl2=garea*vl2
 !Note: garea is the grid box area, glx*gly

return
end subroutine

!=======================================================================

subroutine contint(qq,nqjumps,dq,qqmin,qqmax)

! Computes a contour interval for a field qq from (qq_max-qq_min)/n_qjumps

implicit none

 !Passed variables:
double precision:: qq(0:ny,0:nxm1,nz)
double precision:: dq(nz),qqmin(nz),qqmax(nz)
integer:: nqjumps

 !Local variables:
integer:: ix,iy,iz

do iz=1,nz
  qqmax(iz)=qq(0,0,iz)
  qqmin(iz)=qq(0,0,iz)
  do ix=0,nxm1
    do iy=0,ny
      qqmax(iz)=max(qqmax(iz),qq(iy,ix,iz))
      qqmin(iz)=min(qqmin(iz),qq(iy,ix,iz))
    enddo
  enddo
  dq(iz)=(qqmax(iz)-qqmin(iz))/dble(nqjumps)
enddo

return
end subroutine

!=======================================================================

double precision function rand(i)
 !Returns a random number: i is any integer

implicit double precision(a-h,o-z)
implicit integer(i-n)

call random_number(r)
rand=r

return
end function

!=======================================================================

 !Main end module
end module


C**********************************************
      subroutine RFFT (A,M,INV,S,IFERR,IFSET)
C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      dimension A(1), L(3), INV(1), S(1)
C
C     IFSET=1
      L(1)=M
      L(2)=0
      L(3)=0
      NTOT=2**M
      NTOT2=2*NTOT
      FN=NTOT
      do I=2,NTOT2,2
        A(I)=-A(I)
      end do
      do I=1,NTOT2
        A(I)=A(I)/FN
      end do
      call FFT (A,L,INV,S,IFSET,IFERR)
C
C     MOVE LAST HALF OF A(J)S DOWN ONE SLOT AND ADD A(N) AT BOTTOM TO
C     GIVE ARRAY FOR A1PRIME AND A2PRIME CALCULATION
C
      do I=1,NTOT,2
        J0=NTOT2+2-I
        A(J0)=A(J0-2)
        A(J0+1)=A(J0-1)
      end do
      A(NTOT2+3)=A(1)
      A(NTOT2+4)=A(2)
C
C     CALCULATE A1PRIMES AND STORE IN FIRST N SLOTS
C     CALCULATE A2PRIMES AND STORE IN SECOND N SLOTS IN REVERSE ORDER
C
      K0=NTOT+1
      do I=1,K0,2
        K1=NTOT2-I+4
        AP1RE=.5*(A(I)+A(K1))
        AP2RE=-.5*(A(I+1)+A(K1+1))
        AP1IM=.5*(-A(I+1)+A(K1+1))
        AP2IM=-.5*(A(I)-A(K1))
        A(I)=AP1RE
        A(I+1)=AP1IM
        A(K1)=AP2RE
        A(K1+1)=AP2IM
      end do
      NTO=NTOT/2
      NT=NTO+1
      DEL=3.1415927/FLOAT(NTOT)
      SS=SIN(DEL)
      SC=COS(DEL)
      SI=0.0
      CO=1.0
C
C     COMPUTE C(J)S FOR J=0 THRU J=N
      do I=1,NT
        K6=NTOT2-2*I+5
        AP2RE=A(K6)*CO+A(K6+1)*SI
        AP2IM=-A(K6)*SI+A(K6+1)*CO
        CIRE=.5*(A(2*I-1)+AP2RE)
        CIIM=.5*(A(2*I)+AP2IM)
        CNIRE=.5*(A(2*I-1)-AP2RE)
        CNIIM=.5*(A(2*I)-AP2IM)
        A(2*I-1)=CIRE
        A(2*I)=CIIM
        A(K6)=CNIRE
        A(K6+1)=-CNIIM
        SIS=SI
        SI=SI*SC+CO*SS
        CO=CO*SC-SIS*SS
      end do
C
C     SHIFT C(J)S FOR J=N/2+1 to J=N UP ONE SLOT
      do I=1,NTOT,2
        K8=NTOT+4+I
        A(K8-2)=A(K8)
        A(K8-1)=A(K8+1)
      end do
      do I=3,NTOT2,2
        A(I)=2.*A(I)
        A(I+1)= 2.*A(I+1)
      end do
      return
      end


***
      real*8 FUNCTION pisn(kw,mche,mt)
*
*     Author : N. Giacobbo
*     Date :   27th March 2017
*
*
*     Pari Instability and Pulsation Pair Instability during the
*     supernova explosions.
*     Ref: Woosley 2016 and SEVN implementation (Spera & Mapelli 2017)
*     ----------------------------------------------------------
*     pisn = pair instability correction
*
*
      implicit none
      real*8 hefrac,kpar,val,mche,mt
      integer kw
*
* No correction
*
      pisn = 1.d0
*
*     Pulsation Pair Instability PPISN
*
*     use Table 2 fit from Woosley 2006
*
      if(kw.lt.7)then

         if(mche.gt.32.d0 .and. mche.lt.64.d0)then
*
*     I suppose the total he_tot is well described by the
*     the core mass
*
            hefrac = mche/mt
            kpar = 0.67d0*hefrac + 0.1d0
            if(mche.le.37.d0)then
               pisn = (kpar - 1.d0)/5.d0*mche +
     &                (37.d0 - 32.d0*kpar) / 5.d0
            elseif(mche.gt.37.d0 .and. mche.le.60.d0)then
               pisn = kpar
            else
               pisn = - (kpar/4.d0)*mche + 16.d0*kpar
            endif
*
*     Pair-instability supernova: disintegrated
*
         elseif(mche.ge.64.d0 .and. mche.lt.135.d0)then
            pisn = 0.d0
*
*     end of PISN... again standard direct collapse
*
         else
            pisn = 1.d0
         endif

*
*     use WR table 1 fit from Woosley 2016
*
      elseif(kw.ge.7 .and. kw.le.9)then
*
*     I suppose the is composed only by he and co
*
         if(mt.gt.32.d0 .and. mt.lt.64.d0)then

            hefrac = 1.d0
            if(mt.le.37.d0)then
                pisn = (0.5226d0*hefrac - 0.52974d0)*(mt - 32.d0) +
     &              1.d0
            elseif(mt.gt.37.d0 .and. mt.le.56.d0)then
                val = (0.5226d0*hefrac - 0.52974d0)*5.d0 + 1.d0
                if(val.lt.0.82916d0)then
                   pisn = val
                else
                   pisn = (- 0.1381d0*hefrac + 0.1309d0)*(mt - 56.d0)
     &                  + 0.82916d0
                endif
            else
                pisn = - 0.103645d0*mt + 6.63328d0
            endif
*
*     Pair-instability supernova: disintegrated
*
         elseif(mt.ge.64.d0 .and. mt.lt.135.d0)then
            pisn = 0.d0
*
*     end of PISN... again standard direct collapse
*
         else
            pisn = 1.d0
         endif

      else
         write(*,*) 'Which are those cases?'

      endif
*
      return
**
      end


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program CFIE_test_planewave
    use meshread_mod
    use EFIEDuffy_functions
    use MFIEDuffy_functions
    use EFIE_functions
    use linalg_mod
    use CFIE_mod
    use mpi
    use EFIE_RWG_matrices
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]

    real(8), parameter :: alpha1 = 0.5d0     ! CFIE first constant
    complex(8) :: alpha2                     ! CFIE second constant

    ! Variables
    type(Mesh) :: msh, msh_evl
    complex(8), allocatable :: Z1(:,:), Einc(:,:), V1(:)
    complex(8), allocatable :: Z2(:,:), Hinc(:,:), V2(:), EMat(:, :), Hinc2(:,:)
    complex(8), allocatable :: I1(:), I2(:), I3(:), Epot(:,:,:)
    complex(8), allocatable :: E1(:,:), E2(:,:), E3(:,:)
    real(8), allocatable :: xEvl(:,:)
    real(8) :: ENorm, Error2, Error3
    integer :: nEvl, j
    integer, parameter :: nNS = 6        ! number of quadrature points for EFIE
    integer, parameter :: nNS2 = 6        ! number of quadrature points for EFIE Sauter-Schwab

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8) :: k        ! free-space wavenumber [1/m]
    real(8) :: w        ! angular frequency [rad/s]
    real(8) :: pol(3), src(3)
    character(len=100) :: file_msh, file_evl

    k = 0.1d0                   ! free-space wavenumber [1/m]
    w = k / sqrt(ep0 * mu0)          ! angular frequency [rad/s]
    alpha2 = IU / k * (1 - alpha1)   ! CFIE second constant
    pol = [1.0d0, 1.0d0, 1.0d0]      ! polarization vector
    src = [-0.1d0, -0.1d0, -0.25d0]  ! location of dipole source

    file_msh = 'meshes/convergence_sphere/sph0300.msh' !sph0250
    file_evl = 'meshes/convergence_sphere/sphNF0300.msh'

    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute EFIE matrices
    if (id == 0) print *, "EFIE"
    !call genEFIESauterSchwabMat(Z1, msh, k, nNS, nNS2)
    call genEFIEDuffyMat(Z1, msh, k, nNS, nNS2)
    !call genEFIESauterSchwabMat_RWG(Z1, msh, k, nNS, nNS2)

    ! Compute MFIE matrices
    if (id == 0) print *, "MFIE"
    !call genMFIESauterSchwabMat(Z2, msh, k, EMat)
    call genMFIEMat(Z2, msh, k, EMat)

    ! Solve system
    if (id == 0) then
        allocate(V1(msh%nbEdg))
        allocate(I1(msh%nbEdg))
        allocate(V2(msh%nbEdg))
        allocate(I2(msh%nbEdg))
        allocate(I3(msh%nbEdg))

        ! Incident fields
        call DipoleFieldsOnMesh(pol, src, k, msh, Einc, Hinc)
        Hinc = Hinc / (IU * w * mu0)        ! adjust constants

        Hinc2 = CurlDipoleOnMesh2(pol, src, k, msh)
        Hinc2 = Hinc2 / (IU * w * mu0)        ! adjust constants
        print *, Hinc(5, :)/Hinc2(5, :)
        print *, Hinc(10, :)/Hinc2(10, :)
        print *, Hinc(15, :)/Hinc2(15, :)
        Hinc = Hinc2

!        allocate(Einc(1:msh%nbNod, 3))
!        allocate(Hinc(1:msh%nbNod, 3))
!        Einc = 0d0
!        Hinc = 0d0
!        do j = 1, msh%nbNod
!            Einc(j, 2) = exp(IU*k*msh%POS(j,1))  ! exp(ikx)
!            Hinc(j, 3) = Einc(j, 2) / sqrt(mu0 / ep0)
!        end do

        ! EFIE RHS
        V1 = -genRHS(Einc, msh)
        !V1 = -genRHS_EFIE_RWG(Einc, msh)
        V1 = V1 / (IU * w * mu0)  ! adjust constants

        ! MFIE RHS
        V2 = -genRHSMFIE(Hinc, msh)
        Z2 = -0.5d0*Emat + Z2

        ! Solve
        call linsolve(I1, Z1, V1, msh%nbEdg) ! EFIE
        call linsolve(I2, Z2, V2, msh%nbEdg) ! MFIE
        call linsolve(I3, alpha1*Z1 + alpha2*Z2, alpha1*V1 + alpha2*V2, msh%nbEdg) ! CFIE
    end if

    ! Load eval mesh
    call load_gmsh(file_evl, msh_evl)
    nEvl = msh_evl%nbELm
    allocate(xEvl(1:nEvl,1:3))
    xEvl = msh_evl%CNTR + (msh%h/2.0d0**(0))*msh_evl%NRM

    ! Compute EFIE potencial
    call genEFIEPot(Epot, nEvl, xEvl, msh, k)

    ! Compute BEM solution and error
    if (id==0) then
        Epot = Epot * (IU * w * mu0) ! adjust constants

        ! EFIE
        allocate(E1(1:nEvl,1:3))
        E1(:,1) = matmul(Epot(:,:,1), I1)
        E1(:,2) = matmul(Epot(:,:,2), I1)
        E1(:,3) = matmul(Epot(:,:,3), I1)
        ENorm = maxval(sqrt(abs(E1(:,1))**2+abs(E1(:,2))**2+abs(E1(:,3))**2))

        ! MFIE
        allocate(E2(1:nEvl,1:3))
        E2(:,1) = matmul(Epot(:,:,1), I2)
        E2(:,2) = matmul(Epot(:,:,2), I2)
        E2(:,3) = matmul(Epot(:,:,3), I2)
        E2 = E2 - E1
        Error2 = maxval(sqrt(abs(E2(:,1))**2+abs(E2(:,2))**2+abs(E2(:,3))**2))

        ! CFIE
        allocate(E3(1:nEvl,1:3))
        E3(:,1) = matmul(Epot(:,:,1), I3)
        E3(:,2) = matmul(Epot(:,:,2), I3)
        E3(:,3) = matmul(Epot(:,:,3), I3)
        E3 = E3 - E1
        Error3 = maxval(sqrt(abs(E3(:,1))**2+abs(E3(:,2))**2+abs(E3(:,3))**2))

        write(*,*) 'h ',' Error MFIE: '
        write(*,*) msh%h, Error2 / ENorm

        write(*,*) 'h ',' Error CFIE: '
        write(*,*) msh%h, Error3 / ENorm

        print *, I1(5:10)/I2(5:10)
        print *, I1(5:10)/I3(5:10)
        print *, I2(5:10)/I3(5:10)
    end if

    call MPI_Finalize(ierr)
end program


c
c -------------------------------------------------------------
c
       subroutine vpredy(q,qy,ut,ub,mitot,mjtot,dt,dy,i,msize)
       implicit double precision(a-h,o-z)
       common /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold
       dimension q(mitot,mjtot,4)
       dimension qy(mitot,mjtot,4),ub(msize,4),ut(msize,4)
c
c predictor step for variables at midtime at cell edges for muscl
c        working on ith column
c
       hdtdy = .5d0*dt/dy
       do 80 j = 2, mjtot-2
	     rho = q(i,j,1)
	     u   = q(i,j,2)
	     v   = q(i,j,3)
	     pr  = q(i,j,4)
	     cs2 = gamma*pr/rho
	     cs  = dsqrt(cs2)
	     bt1 = hdtdy*(qy(i,j,4)/cs-rho*qy(i,j,3))
	     bt2 = hdtdy*cs*(qy(i,j,1)-qy(i,j,4)/cs2)
	     bt3 = -1.d0*hdtdy*cs*qy(i,j,2)
	     if (v-cs .le. 0.d0) bt1 = 0.d0
	     if (v .le. 0.d0) then
		bt2 = 0.d0
		bt3 = 0.d0
	     endif
	     off = .5d0 - dmax1(v+cs,0.d0)*hdtdy
c
             ub(j+1,1) = bt1 + bt2 + rho + off*qy(i,j,1)
	     ub(j+1,2) = -bt3 + u + off*qy(i,j,2)
	     ub(j+1,3) = -bt1*cs/rho + v + off*qy(i,j,3)
	     ub(j+1,4) = bt1*cs2 + pr + off*qy(i,j,4)
c
	     rho = q(i,j+1,1)
	     u   = q(i,j+1,2)
	     v   = q(i,j+1,3)
	     pr =  q(i,j+1,4)
	     cs2 = gamma*pr/rho
	     cs  = dsqrt(cs2)
	     bt2 =  hdtdy*cs*(qy(i,j+1,4)/cs2-qy(i,j+1,1))
	     bt3 =  hdtdy*cs*qy(i,j+1,2)
	     bt4 =  -1.d0*hdtdy*(qy(i,j+1,3)*rho+qy(i,j+1,4)/cs)
	     if (v .ge. 0.d0) then
		bt2 = 0.d0
		bt3 = 0.d0
	     endif
	     if (v+cs .ge. 0.d0) bt4 = 0.d0
	     off = .5d0 + dmin1(v-cs,0.d0)*hdtdy
c
	     ut(j+1,1) = bt2 + bt4 + rho - off*qy(i,j+1,1)
	     ut(j+1,2) = -bt3 + u - off*qy(i,j+1,2)
	     ut(j+1,3) = bt4*cs/rho + v - off*qy(i,j+1,3)
	     ut(j+1,4) = bt4*cs2 + pr - off*qy(i,j+1,4)
 80    continue
c
       return
       end


module environment
    use double
    implicit none
    type :: Environ
        ! static parameters
        integer :: zoneLength   ! number of points on a side in the Brill. zone
        real(kind=DP) :: t,&    ! bare in-plane hopping energy
                         tc,&   ! bare c-direction hopping energy
                         beta,& ! inverse temperature
                         x,&    ! hole doping
                         J      ! in-plane singlet energy
        ! self-consistent parameters (expectation values)
        real(kind=DP) :: D,&    ! in-plane holon hopping
                         Dc,&   ! c-direction holon hopping
                         B,&    ! in-plane spinon hopping
                         Bc,&   ! c-direction spinon hopping
                         A,&    ! in-plane singlet formation
                         Ac,&   ! c-direction singlet formation
                         muF,&  ! spinon chemical potential
                         muB    ! holon chemical potential
    end type Environ
contains
    ! --- Constructor for Environ. ---
    function NewEnv(zoneLength, t, tc, beta, x, J)
        integer, intent(in) :: zoneLength
        real(kind=DP), intent(in) :: t, tc, beta, x, J
        type(Environ) :: NewEnv
        ! copy parameters
        NewEnv%zoneLength = zoneLength
        NewEnv%t = t
        NewEnv%tc = tc
        NewEnv%beta = beta
        NewEnv%x = x
        NewEnv%J = J
        ! default values (TODO: change to reasonable guesses)
        NewEnv%D = 0.1_DP
        NewEnv%Dc = 0.1_DP
        NewEnv%B = 0.1_DP
        NewEnv%Bc = 0.1_DP
        NewEnv%A = 0.1_DP
        NewEnv%Ac = 0.1_DP
        NewEnv%muF = 0.1_DP    ! should be positive
        NewEnv%muB = -0.1_DP   ! should be negative
    end function NewEnv

    ! --- Dependent parameters. ---
    ! c-direction singlet energy
    function Jc(env)
        type(Environ), intent(in) :: env
        real(kind=DP) :: Jc
        Jc = (env%tc / env%t) ** 2.0_DP
    end function Jc

    ! effective in-plane spinon hopping energy
    function Eh(env)
        type(Environ), intent(in) :: env
        real(kind=DP) :: Eh
        Eh = env%t * env%D + 0.5_DP * env%J * env%B
    end function Eh

    ! effective c-direction spinon hopping energy
    function Ehc(env)
        type(Environ), intent(in) :: env
        real(kind=DP) :: Ehc
        Ehc = env%tc * env%Dc + 0.5_DP * Jc(env) * env%Bc
    end function Ehc

    ! Minimum of the spinon spectrum.
    ! Should work whether Eh and Ehc are positive or negative.
    function epsilonMinF(env)
        type(Environ), intent(in) :: env
        real(kind=DP) :: epsilonMinF, abPart, cPart
        abPart = abs(2.0_DP * Eh(env))
        cPart = abs(Ehc(env))
        epsilonMinF = -2.0_DP * (abPart + cPart)
    end function epsilonMinF

    ! Minimum of the holon spectrum.
    ! Should work whether tB and tcBc are positive or negative.
    function epsilonMinB(env)
        type(Environ), intent(in) :: env
        real(kind=DP) :: epsilonMinB, abPart, cPart
        abPart = abs(2.0_DP * env%t * env%B)
        cPart = abs(env%tc * env%Bc)
        epsilonMinB = -4.0_DP * (abPart + cPart)
    end function epsilonMinB

    ! --- Momentum-dependent functions. ---
    ! Spinon spectrum.
    function epsilonBarF(env, k)
        type(Environ), intent(in) :: env
        real(kind=DP), dimension(1:3) :: k
        real(kind=DP) :: epsilonBarF
        epsilonBarF = -2.0_DP * (Eh(env) * (cos(k(1)) + cos(k(2))) +&
                                 Ehc(env) * cos(k(3)))
    end function epsilonBarF

    ! Spinon (diagonal-part) hopping energy, including chemical potential.
    ! Minimum is -muF.
    function xiF(env, k)
        type(Environ), intent(in) :: env
        real(kind=DP), dimension(1:3) :: k
        real(kind=DP) :: xiF
        xiF = epsilonBarF(env, k) - epsilonMinF(env) - env%muF
    end function xiF

    ! Holon spectrum.
    function epsilonBarB(env, k)
        type(Environ), intent(in) :: env
        real(kind=DP), dimension(1:3) :: k
        real(kind=DP) :: epsilonBarB
        epsilonBarB = -4.0_DP * (env%t * env%B * (cos(k(1)) + cos(k(2))) +&
                                 env%tc * env%Bc * cos(k(3)))
    end function epsilonBarB

    ! Holon hopping energy, including chemical potential.
    ! Minimum is -muB.
    function xiB(env, k)
        type(Environ), intent(in) :: env
        real(kind=DP), dimension(1:3) :: k
        real(kind=DP) :: xiB
        xiB = epsilonBarB(env, k) - epsilonMinB(env) - env%muB
    end function xiB

    ! Gap function (spinon k-up, minus-k-down coupled part).
    function Delta(env, k)
        type(Environ), intent(in) :: env
        real(kind=DP), dimension(1:3) :: k
        real(kind=DP) :: Delta
        Delta = -2.0_DP * (env%J * env%A * (cos(k(1)) - cos(k(2))) +&
                           Jc(env) * env%Ac * cos(k(3)))
    end function Delta

    ! Energy for spinon-based pseudoparticles obtained after doing Bogoliubvov
    ! transformation.
    function bogoEnergy(env, k)
        type(Environ), intent(in) :: env
        real(kind=DP), dimension(1:3) :: k
        real(kind=DP) :: bogoEnergy
        bogoEnergy = sqrt(Delta(env, k) ** 2.0_DP + xiF(env, k) ** 2.0_DP)
    end function bogoEnergy

    ! --- Distribution functions. ---
    ! Fermi distribution function.
    function fermi(env, energy)
        type(Environ), intent(in) :: env
        real(kind=DP), intent(in) :: energy
        real(kind=DP) :: fermi
        fermi = 1.0_DP / (exp(env%beta * energy) + 1.0_DP)
    end function

    ! Bose distribution function.
    function bose(env, energy)
        type(Environ), intent(in) :: env
        real(kind=DP), intent(in) :: energy
        real(kind=DP) :: bose
        bose = 1.0_DP / (exp(env%beta * energy) - 1.0_DP)
    end function
end module environment


      SUBROUTINE IDF2(EE,E2,    ETA01,ZET01,A2R,A2I,B2R,B2I,C2R,C2I,
     1                R1SQX,DIIJR,DIIJI)
C   ***   INTEGRATES THE NONPLANAR PARTS OF THE INCREMENTAL
C         OSCILLATORY KERNELS FOR UNSTEADY CASES
      EPS  = 0.0001
      AZET = ABS(ZET01)
      DENO = R1SQX-E2
      PARN = ETA01**2 + ZET01**2
      FACR = PARN*A2R + ETA01*B2R + C2R
      FACI = PARN*A2I + ETA01*B2I + C2I
      ETA02=ETA01**2
      ZET02= ZET01**2
      IF  ((AZET/EE) . LE . 0.001)  GO TO  120
      TEST0= ABS((R1SQX-E2)/(2.0*EE*AZET))
      IF (TEST0.GT.0.1)  GO TO 120
      DEN2 = (ETA01+EE)**2+ZET02
      DEN3 = (ETA01-EE)**2+ZET02
      FAC2A= R1SQX*ETA01+(ETA02-ZET02)*EE
      FAC3A= R1SQX*ETA01-(ETA02-ZET02)*EE
      FAC2B= R1SQX+ETA01*EE
      FAC3B= R1SQX-ETA01*EE
      TRM2R= (FAC2A*A2R+FAC2B*B2R+(ETA01+EE)*C2R)/DEN2
      TRM2I= (FAC2A*A2I+FAC2B*B2I+(ETA01+EE)*C2I)/DEN2
      TRM3R=-(FAC3A*A2R+FAC3B*B2R+(ETA01-EE)*C2R)/DEN3
      TRM3I=-(FAC3A*A2I+FAC3B*B2I+(ETA01-EE)*C2I)/DEN3
      IF (TEST0.LE.0.0001)  GO TO 110
      COEF = (2.0*EE)/(R1SQX-E2)
      ARGA = COEF*ZET01
      TEST = ABS(ARGA)
      IF  (TEST.GT.0.3)  GO TO 90
      S    = ARGA**2
      SER  = 1./3.+S*(-1./5.+S*(1./7.+S*(-1./9.+S*(1./11.-S/13.))))
      ALPHA= E2*(COEF**2)*SER
      FUNCT= COEF*(1.0-ALPHA*(ZET01**2)/E2)
      GO TO 100
   90 CONTINUE
      ARGT = COEF*AZET
      ATANA= ATAN(ARGT)
      FUNCT= ATANA/AZET
  100 CONTINUE
      TRM1R= FACR*FUNCT
      TRM1I= FACI*FUNCT
      DIIJR= (TRM1R + TRM2R + TRM3R)/(2.0*ZET02)
      DIIJI= (TRM1I + TRM2I + TRM3I)/(2.0*ZET02)
      GO TO 170
  110 CONTINUE
      FUNCT= 0.0
      GO TO 100
  120 CONTINUE
      DENA = (ETA01+EE)**2 + ZET01**2
      DENB = (ETA01-EE)**2 + ZET01**2
      UP1R = 2.0*(E2*A2R + C2R)
      UP1I = 2.0*(E2*A2I + C2I)
      UP2R = 4.0*E2*ETA01*B2R
      UP2I = 4.0*E2*ETA01*B2I
      TRM1R= (UP1R *(R1SQX+E2) + UP2R )/(DENA*DENB)
      TRM1I= (UP1I *(R1SQX+E2) + UP2I )/(DENA*DENB)
      IF  ((AZET/EE) . LE . 0.001)  GO TO  130
      COEF = (2.0*EE)/(R1SQX-E2)
      ARGA = COEF*ZET01
      TEST = ABS(ARGA)
      IF  (TEST.GT.0.3)  GO TO 125
      S    = ARGA**2
      SER  = 1./3.+S*(-1./5.+S*(1./7.+S*(-1./9.+S*(1./11.-S/13.))))
      ALPHA= E2*(COEF**2)*SER
      FUNCT= COEF*(1.0-ALPHA*(ZET01**2)/E2)
      GO TO 140
  125 CONTINUE
      ARGT= COEF*AZET
      ATANA= ATAN(ARGT)
      FUNCT= ATANA/AZET
      ALPHA= (E2/ZET02)*(1.0-FUNCT*(DENO/(2.0*EE)))
      GO TO 140
  130 CONTINUE
      ALPHA= ((2.0*E2)/(ETA02-E2))**2
  140 CONTINUE
      TRM2R= -ALPHA*FACR/E2
      TRM2I= -ALPHA*FACI/E2
      DIIJR= EE*(TRM1R + TRM2R)/DENO
      DIIJI= EE*(TRM1I + TRM2I)/DENO
  170 CONTINUE
      RETURN
      END


SUBROUTINE spline(x,y,n,yp1,ypn,y2)
!
IMPLICIT NONE
!
! PARAMETER definitions
!
INTEGER,PARAMETER :: nmax = 100
!
! Subroutine arguments
!
INTEGER :: n
REAL :: yp1,ypn
REAL,DIMENSION(n) :: x,y,y2
!
! Local variables
!
INTEGER :: i,k
REAL :: p,qn,sig,un
REAL,DIMENSION(nmax) :: u
!
! + + + argument definitions + + +
!     n -
!     x -
!     y -
!     y2 -
!     yp1 -
!     ypn -

!     + + + parameter definitions + + +
!     nmax -

! + + + local variables

!     + + + local variable definitions + + +
!     i - loop control variable
!     k - loop control variable
!     p -
!     qn -
!     sig -
!     u -
!     un -

IF (yp1.GT..99E30) THEN
  y2(1) = 0.
  u(1) = 0.
ELSE
  y2(1) = -0.5
  u(1) = (3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
END IF
DO i = 2,n - 1
  sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
  p = sig*y2(i-1) + 2.
  y2(i) = (sig-1.)/p
  u(i) = (6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))          &
       & /(x(i+1)-x(i-1))-sig*u(i-1))/p
END DO
IF (ypn.GT..99E30) THEN
  qn = 0.
  un = 0.
ELSE
  qn = 0.5
  un = (3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
END IF
y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.)
DO k = n - 1,1, - 1
  y2(k) = y2(k)*y2(k+1) + u(k)
END DO
!       debug lines. remove after debugging.
!        do i=1,n
!                write(56,*)x(i),y(i),y2(i)
!        end do
!
END SUBROUTINE spline

Project Documents/Source Code Original/Spline.f90


program test_volume
  use geom_distances
  use geom_types
  use geom_volumes
  use geom_utils
  use test_utils
  implicit none

  type(Segment_t) :: segment
  type(Capsule_t) :: capsule
  type(Box_t) :: box
  type(Line_t) :: line
  real(dp) :: t, d2, V, integral

  !----------------------------------------
  ! Point to line
  !----------------------------------------
  call test_group('Point to line')
  call reset(box, segment, capsule)
  line%origin = (/0, 0, 0/)
  line%direction = (/1, 0, 0/)
  call PointLineDistanceSquared(line, (/0d0, 0d0, 0d0/), t, d2)
  call assert(is_close(d2, 0._dp, 1d-14) .and. &
       is_close(t, 0._dp, 1d-14), 'Point at origin')

  call PointLineDistanceSquared(line, (/1d0, 0d0, 0d0/), t, d2)
  call assert(is_close(d2, 0._dp, 1d-14) .and. &
       is_close(t, 1._dp, 1d-14), 'Point at tip')

  line%origin = (/0, 0, 0/)
  line%direction = (/1, 1, 1/)
  call PointLineDistanceSquared(line, (/1d0, 1d0, 1d0/), t, d2)
  call assert(is_close(d2, 0._dp, 1d-14) .and. &
       is_close(t, 1._dp, 1d-14), 'Point at tip (2)')

  line%origin = (/0, 0, 0/)
  line%direction = (/1, 0, 0/)
  call PointLineDistanceSquared(line, (/0d0, 1d0, 0d0/), t, d2)
  call assert(is_close(d2, 1._dp, 1d-14) .and. &
       is_close(t, 0._dp, 1d-14), 'Point on y-axis')

  call PointLineDistanceSquared(line, (/0d0, 0d0, 1d0/), t, d2)
  call assert(is_close(d2, 1._dp, 1d-14) .and. &
       is_close(t, 0._dp, 1d-14), 'Point on z-axis')

  call PointLineDistanceSquared(line, (/0d0, 0d0, 1d0/), t, d2)
  call assert(is_close(d2, 1._dp, 1d-14) .and. &
       is_close(t, 0._dp, 1d-14), 'Point on z-axis')

  call PointLineDistanceSquared(line, (/100d0, 10d0, 20d0/), t, d2)
  call assert(is_close(d2, 500._dp, 1d-14) .and. &
       is_close(t, 100._dp, 1d-14), 'Point far')

  line%origin = (/0, 0, 0/)
  line%direction = (/2, 0, 0/)
  call PointLineDistanceSquared(line, (/100d0, 10d0, 20d0/), t, d2)
  call assert(is_close(d2, 500._dp, 1d-14) .and. &
       is_close(t, 50._dp, 1d-14), 'Point far')
  call test_group_close()

  !----------------------------------------
  ! Point to segment
  !----------------------------------------
  call test_group('Point to segment')
  call reset(box, segment, capsule)
  call PointLineSegDistanceSquared(segment, (/0d0, 0d0, 0d0/), t, d2)
  call assert(is_close(d2, 0._dp, 1d-14) .and. &
       is_close(t, 0.5_dp, 1d-14), 'Point at origin')

  call PointLineSegDistanceSquared(segment, (/-1d0, 0d0, 0d0/), t, d2)
  call assert(is_close(d2, 0._dp, 1d-14) .and. &
       is_close(t, 0._dp, 1d-14), 'Point at start')

  call PointLineSegDistanceSquared(segment, (/1d0, 0d0, 0d0/), t, d2)
  call assert(is_close(d2, 0._dp, 1d-14) .and. &
       is_close(t, 1._dp, 1d-14), 'Point at end')

  call PointLineSegDistanceSquared(segment, (/3d0, 0d0, 0d0/), t, d2)
  call assert(is_close(d2, 4._dp, 1d-14) .and. &
       is_close(t, 1._dp, 1d-14), 'Point along axis')

  call PointLineSegDistanceSquared(segment, (/0d0, 1d0, 2d0/), t, d2)
  call assert(is_close(d2, 5._dp, 1d-14) .and. &
       is_close(t, 0.5_dp, 1d-14), 'Point perp. to axis')

  call PointLineSegDistanceSquared(segment, (/1d0, 1d0, 2d0/), t, d2)
  call assert(is_close(d2, 5._dp, 1d-14) .and. &
       is_close(t, 1._dp, 1d-14), 'Point perp. to axis (at tip)')

  call PointLineSegDistanceSquared(segment, (/2d0, 1d0, 2d0/), t, d2)
  call assert(is_close(d2, 6._dp, 1d-14) .and. &
       is_close(t, 1._dp, 1d-14), 'Point perp. to axis (beyond tip)')

  call test_group_close()

  !----------------------------------------
  ! CpasuleContains
  !----------------------------------------
  call test_group('Capsule contains')
  call reset(box, segment, capsule)
  call assert(CapsuleContains(capsule, (/0._dp, 0._dp, 0._dp/)), 'center of capsule')
  call assert(CapsuleContains(capsule, (/1._dp, 0._dp, 0._dp/)), 'in capsule (x-axis)')
  call assert(CapsuleContains(capsule, (/0._dp, 0.5_dp, 0._dp/)), 'in capsule (y-axis)')
  call assert(CapsuleContains(capsule, (/0._dp, 0._dp, 0.5_dp/)), 'in capsule (z-axis)')
  call assert(CapsuleContains(capsule, (/2._dp, 0._dp, 0._dp/)), 'side of capsule')
  call assert(.not. CapsuleContains(capsule, (/2.00001_dp, 0._dp, 0._dp/)), 'outside of capsule')

  call reset(box, segment, capsule)
  capsule%segment%start = (/-10, 0, 0/)
  capsule%segment%end = (/10, 0, 0/)
  capsule%r = 1.d0
  call assert(CapsuleContains(capsule, (/0._dp, 0._dp, 0._dp/)), 'center of capsule')
  call assert(CapsuleContains(capsule, (/1._dp, 0._dp, 0._dp/)), 'in capsule')
  call assert(CapsuleContains(capsule, (/2._dp, 0._dp, 0._dp/)), 'side of capsule')
  call assert(.not. CapsuleContains(capsule, (/-11.00001_dp, 0._dp, 0._dp/)), 'outside of capsule')

  call test_group_close()

  !----------------------------------------
  ! CpasuleContains
  !----------------------------------------
  call test_group('Box contains')
  call reset(box, segment, capsule)
  box%extents = (/2, 3, 4/)
  call assert(BoxContains(box, (/0._dp, 0._dp, 0._dp/)), 'center of box')
  call assert(BoxContains(box, (/2._dp, 0._dp, 0._dp/)), 'face-x')
  call assert(BoxContains(box, (/0._dp, 3._dp, 0._dp/)), 'face-y')
  call assert(BoxContains(box, (/0._dp, 0._dp, 4._dp/)), 'face-z')
  call assert(BoxContains(box, (/2._dp, 3._dp, 0._dp/)), 'edge-xy')
  call assert(BoxContains(box, (/2._dp, 0._dp, 4._dp/)), 'edge-xz')
  call assert(BoxContains(box, (/0._dp, 3._dp, 4._dp/)), 'edge-yz')
  call assert(.not. BoxContains(box, (/10._dp, 3._dp, 4._dp/)), 'outside')

  call test_group_close()

  !----------------------------------------
  ! Volumes
  !----------------------------------------
  call test_group('Volumes')

  call reset(box, segment, capsule)
  call assert(is_close(BoxVolume(box), 8._dp, 1d-14), 'box volume')
  capsule%segment%end = capsule%segment%start
  call assert(is_close(CapsuleVolume(capsule), 4*pi/3*capsule%r**3, 1d-14), &
       'capsule volume (sphere)')

  call reset(box, segment, capsule)
  call assert(is_close(CapsuleVolume(capsule), 4*pi/3*capsule%r**3 &
       + pi * capsule%r**2 * norm2(capsule%segment%end - capsule%segment%start), 1d-14), &
       'capsule volume')

  ! Compute intersection volume
  call reset(box, segment, capsule)
  capsule%r = 3
  call CapsuleBoxVolume(box, capsule, V)
  call assert(is_close(V, BoxVolume(box), 1d-14), 'box in capsule')

  call reset(box, segment, capsule)
  capsule%segment%start = (/-10, -2, 0/)
  capsule%segment%end = (/10, -2, 0/)
  capsule%r = 2._dp

  box%extents = (/2, 2, 2/)
  box%origin = (/0, 0, 0/)
  ! TODO: better constrain on precision
  call set_depth(6)
  call CapsuleBoxVolume(box, capsule, V)
  call assert(is_close(V, pi/2*capsule%r**2 * 4, 5d-2*V), 'Capsule on box side (depth 6)')

  call set_depth(9)
  call CapsuleBoxVolume(box, capsule, V)
  call assert(is_close(V, pi/2*capsule%r**2 * 4, 5d-2*V), 'Capsule on box side (depth 9)')

  call set_depth(12)
  call CapsuleBoxVolume(box, capsule, V)
  call assert(is_close(V, pi/2*capsule%r**2 * 4, 3d-2*V), 'Capsule on box side (depth 12)')

  call set_depth(15)
  call CapsuleBoxVolume(box, capsule, V)
  call assert(is_close(V, pi/2*capsule%r**2 * 4, 1.5d-2*V), 'Capsule on box side (depth 15)')

  call set_depth(18)
  call CapsuleBoxVolume(box, capsule, V)
  call assert(is_close(V, pi/2*capsule%r**2 * 4, 3d-3*V), 'Capsule on box side (depth 18)')

  call set_depth(21)
  call CapsuleBoxVolume(box, capsule, V)
  call assert(is_close(V, pi/2*capsule%r**2 * 4, 1.5d-3*V), 'Capsule on box side (depth 21)')

  call test_group_close()
  !----------------------------------------
  ! Volumes
  !----------------------------------------
  call test_group('Integrate')
  call reset(box, segment, capsule)
  call set_depth(9)
  capsule%r = 3
  call CapsuleBoxIntegrate(dummyx2, box, capsule, V, integral)
  call assert(is_close(integral, BoxVolume(box) * 2, 1d-14), 'box in capsule')

  call reset(box, segment, capsule)
  capsule%segment%start = (/-10, -2, 0/)
  capsule%segment%end = (/10, -2, 0/)
  capsule%r = 2._dp

  box%extents = (/2, 2, 2/)
  box%origin = (/0, 0, 0/)
  ! TODO: better constrain on precision
  call set_depth(6)
  call CapsuleBoxVolume(box, capsule, V)
  call CapsuleBoxIntegrate(dummyx2, box, capsule, V, integral)
  call assert(is_close(integral, pi/2*capsule%r**2 * 4 * 2, 5d-2*integral), 'Capsule on box side (depth 6)')

  call set_depth(9)
  call CapsuleBoxIntegrate(dummyx2, box, capsule, V, integral)
  call assert(is_close(integral, pi/2*capsule%r**2 * 4 * 2, 5d-2*integral), 'Capsule on box side (depth 9)')

  call set_depth(12)
  call CapsuleBoxIntegrate(dummyx2, box, capsule, V, integral)
  call assert(is_close(integral, pi/2*capsule%r**2 * 4* 2, 3d-2*integral), 'Capsule on box side (depth 12)')

  call set_depth(15)
  call CapsuleBoxIntegrate(dummyx2, box, capsule, V, integral)
  call assert(is_close(integral, pi/2*capsule%r**2 * 4 * 2, 1.5d-2*integral), 'Capsule on box side (depth 15)')

  call set_depth(18)
  call CapsuleBoxIntegrate(dummyx2, box, capsule, V, integral)
  call assert(is_close(integral, pi/2*capsule%r**2 * 4 * 2, 3d-3*integral), 'Capsule on box side (depth 18)')

  call set_depth(21)
  call CapsuleBoxIntegrate(dummyx2, box, capsule, V, integral)
  call assert(is_close(integral, pi/2*capsule%r**2 * 4 * 2, 1.5d-3*integral), 'Capsule on box side (depth 21)')

  call set_depth(3)
  call reset(box, segment, capsule)
  capsule%segment%start = (/-1, -1, -1/)
  capsule%segment%end = (/1, 1, 1/)
  capsule%r = 10._dp

  box%origin = (/0, 0, 0/)
  box%extents = (/1, 1, 1/)
  call CapsuleBoxIntegrate(tophalf, box, capsule, V, integral)
  call assert(is_close(integral, 4._dp, 4d-14), 'Non constant function')

  call test_summary()
contains

  subroutine reset(box, segment, capsule)
    type(Box_t), intent(inout) :: box
    type(Segment_t), intent(inout) :: segment
    type(Capsule_t), intent(inout) :: capsule

    box%origin = (/0, 0, 0/)
    box%u = (/1, 0, 0/)
    box%v = (/0, 1, 0/)
    box%w = (/0, 0, 1/)
    box%extents = (/1, 1, 1/)

    segment%start = (/-1, 0, 0/)
    segment%end = (/1, 0, 0/)

    capsule%segment = segment
    capsule%r = 1._dp

    call set_depth(3)
  end subroutine reset

  subroutine print_details
    print*, 'Box:'
    print*, '----'
    print*, box%origin
    print*, box%u
    print*, box%v
    print*, box%w
    print*, box%extents
    print*, ''
    print*, 'Capsule:'
    print*, '--------'
    print*, capsule%segment%start
    print*, capsule%segment%end
    print*, capsule%r
    print*, ''
    print*, 'Intersection'
    print*, '------------'
    print*, 'd=', sqrt(d2)
  end subroutine print_details

  real(dp) function dummyx2(X)
    real(dp), intent(in) :: X(3)
    dummyx2 = 2._dp
  end function dummyx2

  real(dp) function tophalf(X)
    ! This is only relevant to the test using it.
    real(dp), intent(in) :: X(3)

    if (X(3) > sqrt(3._dp)) then
       tophalf = 1._dp
    else
       tophalf = 0._dp
    end if
  end function tophalf
end program


      subroutine gwtcnr(alato,jg)
      implicit none
      real alato(*),sit,weight,pi
      integer jg,j
c
      pi=2.*asin(1.)
      do j=1,jg*2
         if (j.le.jg) then
            call gwtlt1(sit,weight,j,jg)
         else
            call gwtlt1(sit,weight,jg*2+1-j,jg)
            sit=-sit
         end if
         alato(j)=asin(sit)*180.0/pi
      end do
      end
c
      subroutine gwtcnr8(alato,jg)
      implicit none
      real*8 alato(*),sit,weight,pi
      integer jg,j
c
      pi=2.*asin(1.)
      do j=1,jg*2
         if (j.le.jg) then
            call gwtlt18(sit,weight,j,jg)
         else
            call gwtlt18(sit,weight,jg*2+1-j,jg)
            sit=-sit
         end if
         alato(j)=asin(sit)*180.0/pi
      end do
      end


submodule(euler_interface_m) euler_prob_0008_m
    implicit none

contains

    module character(len=20) function euler0008()
        write (euler0008, "(i20)") ans()
    end function euler0008

    integer(int64) function ans()
        use euler_data_m, only: get_euler_data_0008
        implicit none

        integer(int64) :: long_int(1000), i, s, tmp
        character(len=:), allocatable :: euler_data(:)

        call get_euler_data_0008(euler_data)
        do i = 1, 20
            s = (i - 1)*50 + 1
            read (euler_data(i), "(50(i1))") long_int(s:s + 49)
        end do

        tmp = 0
        do i = 1, 988
            if (product(long_int(i:i + 12)) > tmp) then
                tmp = product(long_int(i:i + 12))
            end if
        end do
        ans = tmp
    end function ans

end submodule euler_prob_0008_m


c     DEMONSTRATE SCPDRV, SCPINT, AND SCPVAL.
c>> 2001-05-22 DRSCPVAL Krogh Minor change for making .f90 version.
c>> 1997-05-29 DRSCPVAL Krogh Special code for C conversion.
c>> 1996-05-28 DRSCPVAL Krogh Added external statement.
c>> 1994-10-19 DRSCPVAL Krogh  Changes to use M77CON
c>> 1987-12-09 DRSCPVAL Lawson  Initial Code.
c--S replaces "?": DR?CPVAL, ?CPDRV, ?CPINT, ?CPVAL
c
      external SCPVAL
c++ Code for .C. is inactive
c%%   long int i;
c++ End
      integer NQ, NR
      real                 P(6),Q(7),R(6),Z,SCPVAL
      data     P/ 5.E0, 2.E0, 10.E0, 8.E0, 6.E0, 4.E0 /
c
      call SCPINT(P,3,Q,NQ)
      call SCPDRV(Q,NQ,R,NR)
      Z=SCPVAL(Q,NQ,6.E0)-SCPVAL(Q,NQ,4.E0)
c++ Code for ~.C. is active
      write(*,1000) P,Q,R,Z
 1000 format(21X,'P =',2F4.0,2X,4F7.2//' INTEGRAL OF P.      Q ='
     *,2F4.0,2X,5F7.2//' DERIVATIVE OF Q.    R =',2F4.0,2X,4F7.2/
     */' DEFINITE INTEGRAL.  Z =',F20.8)
c++ Code for .C. is inactive
c%%   printf( "                     P =%4.0f%4.0f  ", p[0], p[1]);
c%%   for(i=2L; i < sizeof(p)/sizeof(p[1]); i++)
c%%           printf( "%7.2f", p[i] );
c%%   printf( "\n INTEGRAL OF P.      Q =%4.0f%4.0f  ", q[0], q[1]);
c%%   for(i=2L; i < sizeof(q)/sizeof(q[1]); i++)
c%%           printf( "%7.2f", q[i] );
c%%   printf( "\n DERIVATIVE OF Q.    R =%4.0f%4.0f  ", r[0], r[1]);
c%%   for(i=2L; i < sizeof(r)/sizeof(r[1]); i++)
c%%           printf( "%7.2f", r[i] );
c%%   printf( "\n DEFINITE INTEGRAL.  Z =%7.2f\n", z );
c++ End
      stop
      end


! { dg-do  run }
! { dg-options "-ffrontend-optimize -fdump-tree-optimized" }
! PR 66041 - this used to ICE with an incomplete fix for the PR.
program main
  implicit none
  type :: t
    real :: c
  end type t
  type(t), dimension(1,-2:0) :: a1
  real, dimension(3,2) :: b1
  real, dimension(2) :: c1
  real, dimension(1,2) :: c2

  data a1%c /17., -23., 29./
  data b1 / 2.,  -3.,  5.,  -7., 11., -13./

  c1 = matmul(a1(1,:)%c, b1)
  if (any (c1-[248., -749.] /= 0.)) STOP 1

  c2 = matmul(a1%c, b1)
  if (any (c2-reshape([248., -749.],shape(c2)) /= 0.)) STOP 2
end program main

! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } }


C
C      **********************************************************************
C      ********************* SUBROUTINE GEHAN  ******************************
C      **********************************************************************
C
       SUBROUTINE GEHAN (VERB, XY, ID1, ID2, IC, N1, N2, NCOMP, NTOT,
     +                   R1, R2, TEST, PROB)
C
C
C      * THIS SUBROUTINE COMPUTES GEHAN'S GENERALIZED WILCOXON TEST         *
C      * STATISTIC.  THE COMPUTATIONAL FORM IS FROM E.T. LEE , STATISTICAL  *
C      * METHODS FOR SURVIVAL DATA ANALYSIS, 1980, LIFETIME LEARNING        *
C      * PUBLICATIONS, BELM0NT, CA. THE FORM USED IS THE MANTEL METHOD OF   *
C      * ASSIGNING A SCORE TO EACH OBSERVATION BASED ON ITS RELATIVE RANK,  *
C      * FROM EQUATION 5.5 AND EXAMPLE 5.1                                  *
C      *                                                                    *
C      *         SUBROUTINES                                                *
C      *                   STAT                                             *
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)
       LOGICAL  VERB

       DIMENSION R1(NTOT),R2(NTOT)
       DIMENSION XY(NTOT),ID1(NTOT),ID2(NTOT)

C
C      *        COMPUTATION OF R1                                           *
C      *        STEP 1 AND 2 : RANK FROM LEFT TO RIGHT, OMITTING            *
C      *        RIGHT CENSORED VALUES. ASSIGN NEXT HIGHER RANK              *
C      *        TO RIGHT CENSORED VALUES                                    *
C
C
       IRANK = 0
       DO 90 I = 1,NCOMP
          IF (ID1(I) .EQ. 1) THEN
             R1(I) = IRANK + 1
          ELSE
             IRANK = IRANK + 1
             R1(I) = REAL(IRANK)
          ENDIF
  90   CONTINUE
C
C      *        STEP3 : REDUCE THE RANK OF TIED OBSERVATIONS TO             *
C      *        THE LOWEST RANK FOR THE VALUE                               *
C
       K1 = NCOMP - 1
       L1 = 1
  12   IF (XY(L1) .EQ. XY(L1+1)) THEN
C
          JEMP = IABS (ID1(L1) - 1) * IABS (ID1(L1+1) - 1)
          IF (JEMP .NE. 0) THEN
             R1(L1+1) = R1(L1)
             IF (L1 .EQ. K1) GOTO 13
             L1 = L1 + 1
             GOTO 12
          ENDIF
       ENDIF
       IF (L1 .NE. K1) THEN
          L1 = L1 + 1
          GOTO 12
       ENDIF
C
C      *             COMPUTATION OF R2                                      *
C      *             STEP 1 : RANK FROM RIGHT TO LEFT                       *
C
  13   DO 14 I = 1, NCOMP
          R2(I) = REAL(NCOMP - I + 1)
  14   CONTINUE
C
C      *          STEP2 : REDUCE THE RANK OF TIED OBSERVATIONS              *
C      *          TO THE LOWEST FOR THE VALUE                               *
C
       L1 = NCOMP
  22   IF (XY(L1) .EQ. XY(L1-1)) THEN
C
          JEMP = IABS (ID1(L1) - 1) * IABS (ID1(L1-1) - 1)
          IF (JEMP .NE. 0) THEN
             R2(L1-1) = R2(L1)
             IF (L1 .EQ. 2) GOTO 23
             L1 = L1 - 1
             GOTO 22
          ENDIF
       ENDIF
       IF (L1 .NE. 2) THEN
          L1 = L1 - 1
          GOTO 22
       ENDIF

  23   IF (IC .NE. 0) THEN
C
C      *         STEP 3 : REDUCE THE RANK OF RIGHT CENSORED                 *
C      *         OBSERVATION TO UNITY                                       *
C
          DO 24 I = 1,NCOMP
             IF (ID1(I) .NE. 0)  R2(I) = 1.0
  24      CONTINUE
       ENDIF
C
C      *               COMPUTE FINAL SCORES - R1(I)                         *
C
       DO 25 I = 1,NCOMP
          R1(I) = R1(I) - R2(I)
  25   CONTINUE

       CALL STAT (VERB, ID1, ID2, N1, N2, NCOMP, NTOT, R1, TEST)
       PROB = 1.0 - AGAUSS (TEST)

       RETURN
       END