        program s_pscorg
*******************************************************************************
*
*       is a phase screen simulator which produces artificial fringe
*       or speckle patterns and obtain integrated power spectrum or(/and)
*       optionally specified bispectral components.
*       The atmospheric disturbance is given by the Kolmogorov spectrum.
*       Seeing condition, aperture configuration and the object ( at this
*       point, only multiple point sources ) and the usage of the phase screen
*       must be specified by the user in an ascii input file.
*
*       Following is a sample input file. (free format, ! indicates a
*       comment line.)
*
*       ! seed for random number generator (large odd integer)
*       Random
*       7597551
*       ! outer scale and inner scale of the turbulence(m) - recommended values
*       Turbulence
*       10.0  0.01
*       ! central wavelength(m), fractional bandwidth, sampling points
*       Wavelength
*       0.65e-6 0.016 3
*       ! source: # of point sources
*       !         intensity(arbitrary unit), position offset(x,y) in arcsecond
*       Source
*       2
*       1.0   0.0  0.0
*       0.5   0.02 0.02
*       ! # of circular apertures (including voids)
*       ! configuraton: center of aperture(x,y), radius(m) and type
*       ! 1 is an aperture,0 is a void. Voids should follow ordinary apertures.
*       ! Example: annular mask
*       Aperture
*       2
*       0.0 0.0 2.0  1
*       0.0 0.0 1.9  0
*       ! Multiple subsets are taken out of one phase screen.
*       ! Equally spaced sampling is specified by
*       ! x_min, x_max, step size in x(m)
*       ! y_min, y_max, step size in y(m)
*       Phase_screen
*       1.25 8.75  0.14
*       1.25 8.75  2.5
*       ! total number of frames to be processed
*       Frame
*       100
*       ------ as an option `no atmosphere' can be specified by ------
*       ! obtaining beam pattern
*       No_disturbance
*       --------------------------------------------------------------
*
*       Written in standard FORTRAN and expected to run both on VMS and UNIX
*       simply by replacing FFT routines and random number generator.
*       On UNIX all tempory arrays are to be dynamically allocated by 'calloc()'
*       Source code should be called pscreen.for on VMS, pscreen.f on UNIX.
*       On a vector machine, effeciency of loops should be reconsidered.
*
*       This is a re-organized version of the pscsn.for developed on Tacos.
*       The program is planned to be as users oriented as possible for the
*       future development of Optical/IR interferometry.
*
*       version 1.0    Dec 25, 1988 (Merry Christmas!)     Tadashi Nakajima
*       Today's resolution : `I will have real holidays next year and live
*                             a human life.'
*       version 2.0    Dec 30, 1988   Now sharp cut-offs of fluctuation power
*       spectrum at kapmin and kapmax are introduced to investigatate the
*       relative significance of the diffractive effect and refractive effect.
*       For instance, the refractive effect can be seen by setting lo = 0.1,
*       while the diffractive effect can be investigated by setting L0 = 0.4.
*******************************************************************************
*------ declarations ---------*
*       constants
        real*4    pi, rapdeg, rapmin, rapsec
        complex iu

*       record size
        integer*4  RECS
        parameter( RECS = 512 )

*       integrated structure constant of the phase fluctuation
        real*4 LCn2

*       size of phase screen and resolution (m/pix)
        real*4 Ls, Lp
        parameter( Ls = 10.24 )
        parameter( Lp = 0.02  )

*       size of phase screen, size of power spectrum
        integer*4 Ns, Np
        parameter( Ns = 512  )
        parameter( Np = Ns/2 )

*       wave number, spatial frequencies and scale length of tubulence
        real k, kapmax, kapmin, L0, dkap, lambda, lo

*       complex phase screen, real and imag are independent.
        complex psc(Ns,Ns)

*       power spectrum array
        real*4 pwr(Np,Np)

*       input control parameter file and output power spectrum file
        character*30 ifile, ofile

*       I/O units
        integer*4 f_in, f_out
        parameter( f_in = 11, f_out = 12 )

*       # of frames, # of screens, # of frames per screen
        integer*4  nframe, nscreen, frm_per_scr

*       maximum # of components in source, maximum number of apertures
        integer*4 Maxcomp, Maxap
        parameter( Maxcomp = 50, Maxap = 15 )

*       source information (intensity and position in arcsec)
        real*4 s_int(Maxcomp), s_pos(Maxcomp,2)

*       aperture information (coordinate, radius, type)
        real*4 c_pos(Maxap,2), c_rad(Maxap)
        integer*4 c_typ(Maxap)
*
        common pi,rapdeg,rapmin,rapsec, iu
        common k, kapmax, kapmin, L0, LCn2, dkap, lambda
        common nframe, nscreen, frm_per_scr
        common x_min, x_max, xstep, y_min, y_max, ystep
        common ncomp, ncircle, nsamp, fraction

*       work area for subroutine power
        real*4  image1(Np,Np), image2(Np,Np),  ary1(Np,Np), ary2(Np,Np)
        complex pdata1(Np,Np), pdata2(Np,Np), cary1(Np,Np), cary2(Np,Np)

*       variables local to main program
        character*80 comment
        integer*4 seed, no_dist

*       common variables are not compatible with parameter statement.
        pi = 3.141592653
        rapdeg = pi/180.0
        rapmin = rapdeg/60.0
        rapsec = rapdeg/3600.0
        iu = (0.0,1.0)
        LCn2 = 5.0e-13

* JLP
        call jlp_begin
        call jlp_inquifmt

*       input file names
        write(*,10)
   10   format(1x,' input ascii file name : ',$)
        read(*,'(a)') ifile
        write(*,20)
   20   format(1x,'output power file name : ',$)
        read(*,'(a)') ofile
        write(*,25)
   25   format(1x)

*       read the input file
        open(unit=f_in, file=ifile, status='old')

   30   format(a80)
   35   format(1x,a80)
        do 40 j=1,100

          read(f_in,30,end=100) comment
          write(*,35) comment

          if( comment(1:1) .eq. '!') goto 40
C Keyword "Random", parameter: seed (random generator):
          if( comment(1:1) .eq. 'R' .or. comment(1:1) .eq. 'r') then
            read(f_in,*) seed
            backspace f_in
            read(f_in,30,end=100) comment
            write(*,35) comment
          end if
C Keyword "Turbulence", parameters: outer and inner  scales
          if( comment(1:1) .eq. 'T' .or. comment(1:1) .eq. 't') then
            read(f_in,*) L0, lo
            backspace f_in
            read(f_in,30,end=100) comment
            write(*,35) comment
          end if
C Keyword "Wavelength", parameters: central wavel., fractional bandwidth,
C sampling points
          if( comment(1:1) .eq. 'W' .or. comment(1:1) .eq. 'w') then
            read(f_in,*) lambda, fraction, nsamp
            backspace f_in
            read(f_in,30,end=100) comment
            write(*,35) comment
          end if
C Keyword "Source", parameters: number of points, followed by
C Intensity1, X1, Y1
C Intensity2, X2, Y2...
          if( comment(1:1) .eq. 'S' .or. comment(1:1) .eq. 's') then
            read(f_in,*) ncomp
            backspace f_in
            read(f_in,30,end=100) comment
            write(*,35) comment
            do n=1,ncomp
              read(f_in,*) s_int(n),s_pos(n,1),s_pos(n,2)
              backspace f_in
              read(f_in,30,end=100) comment
              write(*,35) comment
            end do
          end if
C Keyword "Aperture", parameters: number of apertures, followed by
C Xcenter, Ycenter, radius, type (0 or 1)
          if( comment(1:1) .eq. 'A' .or. comment(1:1) .eq. 'a') then
            read(f_in,*) ncircle
              backspace f_in
              read(f_in,30,end=100) comment
              write(*,35) comment
            do n=1,ncircle
              read(f_in,*) c_pos(n,1),c_pos(n,2),c_rad(n),c_typ(n)
              backspace f_in
              read(f_in,30,end=100) comment
              write(*,35) comment
            end do
          end if
C Keyword "Phase screen", parameters: xmin, xmax, step
          if( comment(1:1) .eq. 'P' .or. comment(1:1) .eq. 'p') then
            read(f_in,*) x_min, x_max, xstep
            backspace f_in
            read(f_in,30,end=100) comment
            write(*,35) comment
            read(f_in,*) y_min, y_max, ystep
            backspace f_in
            read(f_in,30,end=100) comment
            write(*,35) comment
          end if
C Keyword "Frame", parameters: nber of frames
          if( comment(1:1) .eq. 'F' .or. comment(1:1) .eq. 'f') then
            read(f_in,*) nframe
            backspace f_in
            read(f_in,30,end=100) comment
            write(*,35) comment
          end if
C Keyword "No disturbance" (no atmosphere)
          if( comment(1:1) .eq. 'N' .or. comment(1:1) .eq. 'n') then
            no_dist = 1
          end if

   40   continue
  100   continue

*       k: wave number, kap: spatial frequency in aperture plane

        k = 2.0 * pi / lambda

        if (Ls .lt. L0) then
          kapmin = 2.0 * pi / Ls
        else
          kapmin = 2.0 * pi / L0
        end if

        if (lo .lt. Lp) then
           kapmax = 2.0 * pi / Lp
        else
           kapmax = 2.0 * pi / lo
        end if

*       dkap: one pixel in spatial frequency in aperture plane
        dkap = 2.0 * pi / Ls
*
        frm_per_scr =
     1  (int((x_max-x_min)/xstep)+1)*(int((y_max-y_min)/ystep)+1)
        print *, 'frm_per_scr ',frm_per_scr
*
        if( mod(nframe,frm_per_scr) .eq. 0 ) then
          nscreen = nframe / frm_per_scr
        else
          nscreen = nframe / frm_per_scr + 1
        end if

*       Two real phase screens per complex random number generation in Fourier
*       domain.

        if( mod(nscreen,2) .eq. 0 ) then
          ncall = nscreen/2
        else
          ncall = nscreen/2 + 1
        end if

        do 300 i = 1, ncall
*------------------------------------
        if ( no_dist .eq. 1 ) then
*       no atmospheric disturbance
          do iz=1, Ns
            do jz=1, Ns
              psc(iz,jz) = (0.0,0.0)
            end do
          end do
        else
*       create a complex phase screen
        write(*,310) i
  310   format('+', 'generating ',i3,'th complex phase screen')
        call  screen(psc, Ns, seed)
        end if

*       sample phase screen, form images, calculate power

        call  power(psc, Ns, pwr, Np, iframe, Maxcomp, Maxap,
     1     s_int, s_pos, c_pos, c_rad, c_typ, pdata1, pdata2,
     2             image1, image2, ary1, ary2, cary1, cary2)

          if(iframe .ge. nframe) goto 400
*
*------------------------------------
  300   continue
*

*       normalize integrated power spectrum
  400   zero = pwr(Np/2+1,Np/2+1)
        do lx=1, Np
          do ly=1, Np
            pwr(lx,ly) = pwr(lx,ly)/zero
          end do
        end do

*       create a figaro file

        No = Np*Np
        call jlp_writeimag(pwr,Np,Np,Np,ofile,ocomments)
*
        call jlp_end
        stop
        end

        subroutine screen(psc, Ns, seed)
***************************************************************************
*       creates complex phase screen
***************************************************************************
        complex psc(Ns,Ns)
        real*4 k, kapmax, kapmin, L0, LCn2, dkap, u, work
        integer*4 frm_per_scr
        complex iu
        common pi,rapdeg,rapmin,rapsec, iu
        common k, kapmax, kapmin, L0, LCn2, dkap, lambda
        common nframe, nscreen, frm_per_scr
        common x_min, x_max, xstep, y_min, y_max, ystep
        common ncomp, ncircle, nsamp, fraction

*       radial spatial frequency in aperture plane
        real*4 kap

*       seed for the random number generator, dimension array for fft
*       origin of the phase screen
        integer*4 seed, N(2), Nc

*------ generation of random phase in spatial domain -------------
*       Complex Gaussian random numbers are generated by
*       the inverse transform method.

        N(1) = Ns
        N(2) = Ns
        Nc = Ns/2+1

        do 100 jx=1, Ns
          do 110 jy=1, Ns

            kap = dkap*sqrt( float( (jx-Nc)**2+(jy-Nc)**2 ) )

*           introducing smooth cut-offs below kapmin and beyond kapmax.

            if(kap .gt. kapmax) atten = exp(-(kap-kapmax)/(5.0*dkap))
            if(kap .lt. kapmin) atten = exp(-(kapmin-kap)/(5.0*dkap))
            if(kap.le.kapmax .and. kap.ge.kapmin) atten = 1.0

*           kap**(-11/3) is undefined at kap=0.
            if(kap .eq. 0.0) kap = dkap

            call jlp_random_init(seed)
10          call jlp_random(u)
            if ( u.gt.0.0 ) then
              radi = sqrt(-2.0*log(u))
            else
              goto 10
            end if
            Fs = 0.033*pi*LCn2*k*k*2.0*kap**(-11.0/3.0)*dkap*dkap
            call jlp_random(work)
            psc(jx,jy) = atten*sqrt(Fs)*radi*cexp(iu*2.0*pi*work)

  110     continue
  100   continue

*---------- Fourier transform ------------------------------
*       shift origin of Fourier space to (Nc,Nc)
        do i=1,Ns,2
          do j=1,Ns,2
            psc(i+1,j) = -psc(i+1,j)
            psc(i,j+1) = -psc(i,j+1)
          end do
        end do

        write(*,555) N(1),N(2)
  555   format('+', 'start ',i3,'x',i3,' sized fft              ')
        call fourn1(psc,N,2,-1,+1)
        write(*,666)
  666   format('+', 'end fft for screen                         ')

*       now psc is a complex random phase screen
*       to avoid discontinuity shift origin of phase screen to (Nc,Nc)
        do i=1,Ns,2
          do j=1,Ns,2
            psc(i+1,j) = -psc(i+1,j)
            psc(i,j+1) = -psc(i,j+1)
          end do
        end do

        return
        end

        subroutine power(psc, Ns, pwr, Np, iframe, Maxcomp, Maxap,
     1          s_int, s_pos, c_pos, c_rad, c_typ, pdata1, pdata2,
     2                   image1, image2, ary1, ary2, cary1, cary2)
*******************************************************************************
*       produces fringe/speckle patterns of multiple point sources.
*       Finite bandwidth effect is taken into account.
*******************************************************************************
*       source information (intensity and position in arcsec)
        real*4 s_int(Maxcomp), s_pos(Maxcomp,2)
*       aperture information (coordinate, radius, type)
        real*4 c_pos(Maxap,2), c_rad(Maxap)
        integer*4 c_typ(Maxap)
        real*4  lpix
        complex psc(Ns,Ns)
        real*4 k, kapmax, kapmin, Lo, LCn2, dkap
        integer*4 frm_per_scr
        complex iu

        common pi,rapdeg,rapmin,rapsec,iu
        common k, kapmax, kapmin, L0, LCn2, dkap, lambda
        common nframe, nscreen, frm_per_scr
        common x_min, x_max, xstep, y_min, y_max, ystep
        common ncomp, ncircle, nsamp, fraction
*
        integer*4 N(2)

*       power spectrum
        real*4 pwr(Np,Np)

*       temporary arrays
        real*4  image1(Np,Np), image2(Np,Np),  ary1(Np,Np), ary2(Np,Np)
        complex pdata1(Np,Np), pdata2(Np,Np), cary1(Np,Np), cary2(Np,Np)

        N(1) = Np
        N(2) = Np
        lpix = 10.24/Ns
        Wc = Np/2+1
        Scale = Ls/lambda*Np/Ns*rapsec

*       setting apertures on Np sized window in Ns sized complex phase screen

        do 10 x=x_min,x_max,xstep
        do 20 y=y_min,y_max,ystep
**************************** major loop ***************************************

        write(*,111) x,y
  111   format('+',' creating a pair of speckle/fringe patterns',1x,
     1         'xy',f10.3,1x,f10.3)

        write(*,333) ncircle, nsamp, c_typ(1), c_typ(2)
  333   format(1x,'ncircle nsamp typ(1) typ(2) ',1x,4(i2,1x) )

        do 100 loop1=1,nsamp
**************** intermediate loop *****************
*        nsamp data points within the bandpass
         factor =  1.0 + fraction*(loop1 - nsamp/2)

         npx = 0

          do 30 i=1,ncircle
*-----------------------------------------
*       filling pdata with aperture phases

            do 40 xa = x+c_pos(i,1)-c_rad(i), x+c_pos(i,1)+c_rad(i), lpix
            do 50 ya = y+c_pos(i,2)-c_rad(i), y+c_pos(i,2)+c_rad(i), lpix
              ox = xa-x-c_pos(i,1)
              oy = ya-y-c_pos(i,2)
              if( ox*ox+oy*oy .lt. c_rad(i)*c_rad(i) ) then
                ix = nint( (xa-x)/lpix )+Wc
                iy = nint( (ya-y)/lpix )+Wc

*       shift origin of the window to (Wc,Wc)
                lx = nint(xa/lpix)
                ly = nint(ya/lpix)

                if( c_typ(i) .eq. 1) npx = npx+1
                if( c_typ(i) .eq. 0) npx = npx-1

                if( mod(npx,100) .eq. 0 ) then
                  write(*,777) npx
                end if
  777   format('+', '# of  positive pixels',1x,i5)

                if( mod(ix+iy,2) .eq. 0 ) then
                  pdata1(ix,iy) = cexp( iu*factor*real(psc(lx,ly)) )*c_typ(i)
                  pdata2(ix,iy) = cexp(iu*factor*aimag(psc(lx,ly)) )*c_typ(i)
                else
                  pdata1(ix,iy) =-cexp( iu*factor*real(psc(lx,ly)) )*c_typ(i)
                  pdata2(ix,iy) =-cexp(iu*factor*aimag(psc(lx,ly)) )*c_typ(i)
                end if

              end if
   50       continue
   40       continue
*-----------------------------------------
   30     continue

*       simulate propagation from aperture plane to detector plane

        call fourn1(pdata1,N,2,-1,+1)
        call fourn1(pdata2,N,2,-1,+1)

*       form speckle/fringe patterns
        do ix=1, Np
          do iy=1, Np
            image1(ix,iy) = image1(ix,iy) +
     1                      real(pdata1(ix,iy)*conjg(pdata1(ix,iy)))
            image2(ix,iy) = image2(ix,iy) +
     2                      real(pdata2(ix,iy)*conjg(pdata2(ix,iy)))
          end do
        end do

*       reset pdata1 and pdata2
        do ix=1, Np
          do iy=1, Np
            pdata1(ix,iy) = (0.0,0.0)
            pdata2(ix,iy) = (0.0,0.0)
          end do
        end do

******************* end of loop1 ********************
  100   continue

        do 60 loop2=1,ncomp
*--------------------------------------------
*       ncomp components in source structure
          dx = int(Scale * s_pos(loop2,1))
          dy = int(Scale * s_pos(loop2,2))

        if( dx .ge. 0 .and. dy. ge. 0) then
          do ix=1,Np-dx
          do iy=1,Np-dy
            ary1(ix+dx,iy+dy) = ary1(ix,iy)+s_int(loop2)*image1(ix,iy)
            ary2(ix+dx,iy+dy) = ary2(ix,iy)+s_int(loop2)*image2(ix,iy)
          end do
          end do
        end if

        if( dx .ge. 0 .and. dy. lt. 0) then
          do ix=1,Np-dx
          do iy=-dy+1,Np
            ary1(ix+dx,iy+dy) = ary1(ix,iy)+s_int(loop2)*image1(ix,iy)
            ary2(ix+dx,iy+dy) = ary2(ix,iy)+s_int(loop2)*image2(ix,iy)
          end do
          end do
        end if

        if( dx.lt.0 .and. dy.ge.0) then
          do ix=-dx+1,Np
          do iy=1,Np-dy
            ary1(ix+dx,iy+dy) = ary1(ix,iy)+s_int(loop2)*image1(ix,iy)
            ary2(ix+dx,iy+dy) = ary2(ix,iy)+s_int(loop2)*image2(ix,iy)
          end do
          end do
        end if

        if( dx.lt.0 .and. dy.lt.0) then
          do ix=-dx+1,Np
          do iy=-dy+1,Np
            ary1(ix+dx,iy+dy) = ary1(ix,iy)+s_int(loop2)*image1(ix,iy)
            ary2(ix+dx,iy+dy) = ary2(ix,iy)+s_int(loop2)*image2(ix,iy)
          end do
          end do
        end if
*-------------------------------------------
   60   continue

        write(*,320) iframe+1

*       shift origin of the image to (Wc,Wc) before fourier transform
        do ix=1,Np,2
        do iy=1,Np,2
          cary1(ix,iy)     = ary1(ix,iy)
          cary1(ix+1,iy+1) = ary1(ix+1,iy+1)
          cary1(ix+1,iy)   =-ary1(ix+1,iy)
          cary1(ix,iy+1)   =-ary1(ix,iy+1)
        end do
        end do

        call fourn1(cary1,N,2,-1,+1)

        do jx=1,Np
        do jy=1,Np
          pwr(jx,jy) = pwr(jx,jy) + real(cary1(jx,jy)*conjg(cary1(jx,jy)))
        end do
        end do

        iframe = iframe + 1
        if( iframe .ge. nframe) return

        write(*,320) iframe+1
  320   format('+', 'processing ',i4,' th frame                    ')

*       shift origin of the image to (Wc,Wc) before fourier transform
        do ix=1,Np,2
        do iy=1,Np,2
          cary2(ix,iy)     = ary2(ix,iy)
          cary2(ix+1,iy+1) = ary2(ix+1,iy+1)
          cary2(ix+1,iy)   =-ary2(ix+1,iy)
          cary2(ix,iy+1)   =-ary2(ix,iy+1)
        end do
        end do

        call fourn1(cary2,N,2,-1,+1)

        do jx=1,Np
        do jy=1,Np
          pwr(jx,jy) = pwr(jx,jy) + real(cary2(jx,jy)*conjg(cary2(jx,jy)))
        end do
        end do

        iframe = iframe + 1
        if( iframe .ge. nframe) return

*       reset temporary arrays
        do jx=1,Np
          do jy=1,Np
            image1(jx,jy) = 0.0
            image2(jx,jy) = 0.0
              ary1(jx,jy) = 0.0
              ary2(jx,jy) = 0.0
             cary1(jx,jy) = (0.0,0.0)
             cary2(jx,jy) = (0.0,0.0)
          end do
        end do

************************* end of major loop ***********************************
   20   continue
   10   continue

        return
        end
**********************************************************************
        include 'hrsa:fft_jlp.for'


      SUBROUTINE X TRNS Y (X,Y,ALPHA)
C*******
C     X TRNS Y  FORMS THE DOT PRODUCT X TRANSPOSE * Y = ALPHA
C*******
      DOUBLE PRECISION   X(1)      ,Y(1)     ,ALPHA
      COMMON   /INVPWX/  AAA       ,NCOL
      ALPHA = 0.D0
      DO 10 I=1,NCOL
   10 ALPHA = ALPHA + X(I)*Y(I)
      RETURN
      END


C     File: goto_09.f
C     A simple program with a single forward conditional goto with 3-level
C     difference in goto and label.
C     The program computes and prints out the values of n! for n in [1,10].

      program factorial
      implicit none

      integer i, n, fact

      i = 0
      n = 10
      fact = 0

      do i = 1, n
         if (i .lt. 20) then
             if (i .eq. 1) then
                fact = fact + 1
             elseif (i .le. 10) then
                fact = fact * i
             else
                goto 222
             end if
             write (*, 10) i, fact
         end if
      end do

 222  stop
 10   format('i = ', I3, '; fact = ', I8)

      end program factorial


!============================ fluid_constants ================================80
!
! Initialize constants dependent on ratio of specific heats ( gamma ) or
! the specific gas constant, R
! NOTE: x implies '1 over'
!
!=============================================================================80

module fluid_constants

  use set_precision, only : dp

  implicit none

  private

  public :: r     ! Gas constant
  public :: cv
  public :: cp
  public :: gamma ! Ratio of specific heats
  public :: gm1
  public :: gp1
  public :: xg
  public :: xgm1
  public :: xgp1
  public :: gxgm1
  public :: xg2m1
  public :: gxg2m1
  public :: gm1xgp1
  public :: gp1xgm1

  public :: set_fluid_constants

! Set initial values
  real(dp) :: r = 287.0_dp
  real(dp) :: cv
  real(dp) :: cp
  real(dp) :: gamma = 1.4_dp
  real(dp) :: gm1   = 0.4_dp
  real(dp) :: gp1   = 2.4_dp
  real(dp) :: xg    = 1.0_dp/1.4_dp
  real(dp) :: xgm1  = 1.0_dp/0.4_dp
  real(dp) :: xgp1  = 1.0_dp/2.4_dp
  real(dp) :: gxgm1 = 1.4_dp/0.4_dp
  real(dp) :: xg2m1 = 1.0_dp/(1.4_dp**2-1.0_dp)
  real(dp) :: gxg2m1  = 1.4_dp/(1.4_dp**2-1.0_dp)
  real(dp) :: gm1xgp1 = 0.4_dp/2.4_dp
  real(dp) :: gp1xgm1 = 2.4_dp/0.4_dp

contains

!=========================== set_fluid_constants =============================80
!
!  Gamma is set by the namelist input, all other constants are defined here
!
!=============================================================================80
  subroutine set_fluid_constants()

    use set_constants, only : one

    continue

    gm1    = gamma - one
    gp1    = gamma + one
    xg     = one / gamma
    xgm1   = one / (gamma - one)
    xgp1   = one / (gamma + one)
    xg2m1  = one / (gamma*gamma - one)
    gxgm1  = gamma / (gamma - one)
    gxg2m1 = gamma / (gamma*gamma - one)
    gm1xgp1 = gm1/gp1
    gp1xgm1 = gp1/gm1

    cv = R*xgm1
    cp = R*gxgm1

  end subroutine set_fluid_constants

end module fluid_constants


      real function intrpl(x1,y1,x2,y2,x)
c
c     + + + PURPOSE + + +
c
c     Function INTRPL interpolates between columnar table entries.
c
c     Called from: SR TABLE
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real x1, y1, x2, y2, x
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     x1 -
c     y1 -
c     x2 -
c     y2 -
c     x  -
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
cd    Modified by S. Dun, May 24, 2005
cd    intrpl = ((y2-y1)*(x-x1)/(x2-x1)) + y1
      if(x2 .eq. x1) then
cw   Modified by L. Wang, 03/01/2010
cw          intrpl = (y2-y1)/2
          intrpl = (y2+y1)/2
cw   End modifying
      else
          intrpl = ((y2-y1)*(x-x1)/(x2-x1)) + y1
      endif
cd   End modifying
      return
      end


program gen_be_vertloc

   use da_gen_be, only : da_eof_decomposition

   implicit none

   integer, parameter    :: ni = 1000
   integer, parameter    :: stdout = 6
   character (len=3)     :: cnk                       ! vertical level
   real*8, parameter       :: rscale = 0.1
   real*8, parameter       :: var_threshold = 0.99

   integer               :: i, k, k1, m,nk,nk2
   integer               :: nm
   integer               :: ktarget
   real*8                  :: ni1_inv
   real*8                  :: nk_inv, nk3_inv
   real*8                  :: kscale, kscale_invsq
   real*8                  :: kdist
   real*8                  :: r
   real*8                  :: totvar, totvar_inv, cumvar
   real*8,allocatable      :: rho(:,:)
   real*8,allocatable      :: e(:,:)
   real,allocatable      :: cov(:,:)
   real*8,allocatable      :: eval(:)
   real*8,allocatable      :: evec(:,:)
   real*8,allocatable      :: v(:)
   real*8,allocatable      :: x(:)

  cnk=""
  call getarg( 1, cnk )
  read(cnk,'(i3)')nk2
  nk=nk2-1
  write(stdout,'(a,i6)') ' vertical level = ', nk2

  allocate(rho(1:nk,1:nk))
  allocate(e(1:ni,1:nk))
  allocate(cov(1:nk,1:nk))
  allocate(eval(1:nk))
  allocate(evec(1:nk,1:nk))
  allocate(v(1:nk))
  allocate(x(1:nk))
   ni1_inv = 1.0 / real (ni - 1)
   nk_inv = 1.0 / real (nk)
   nk3_inv = 1.0 / real (nk-3)

!  Specify probability densities:
   do k = 1, nk
      kscale = 10.0 * real(k) * nk_inv  ! Very simple parametrization of vertical variation of localization scale.
!      kscale = 3.0 + 7.0 * real(k-3) * nk3_inv  ! Very simple parametrization of vertical variation of localization scale.
!      kscale = 10.0
      kscale_invsq = 1.0 / ( kscale * kscale )
      do k1 = k, nk
         kdist = k1 - k
         rho(k,k1) = exp ( -real(kdist * kdist) * kscale_invsq )
         rho(k1,k) = rho(k,k1)
      end do
   end do
   cov = rho

!  Create random variables:
!   k = 1
!   do i = 1, ni
!      do k1 = 1, nk
!         call da_gauss_noise( r )
!         r = rscale * r
!         e(i,k1) = rho(k,k1) + r
!         write(17,'(i5,f15.5)')k1, e(i,k1)
!      end do
!      k = k + 1
!      if ( k > nk ) k = 1
!   end do

!  Calculate covariance matrix:

!   do k = 1, nk
!      do k1 = k, nk
!         cov(k,k1) = ni1_inv * sum( e(1:ni,k) * e(1:ni,k1) )
!         cov(k,k1) = rho(k,k1)
!         cov(k1,k) = cov(k,k1)
!      end do
!   end do

!------------------------------------------------------------------------------------------------
! Calculate eigenvectors/values:
!------------------------------------------------------------------------------------------------

   call da_eof_decomposition( nk, cov, evec, eval )

!  Eliminate negative eigenvalues:
   totvar = sum(eval(1:nk))
   do k = 1, nk
     if ( eval(k) < 0.0 ) eval(k) = 0.0
   end do
   totvar_inv = 1.0 / sum(eval(1:nk))
   eval(:) = eval(:) * totvar * totvar_inv ! Preserve total variance before -ve values removed.

!  Calculate truncation:
   nm = 0
   totvar_inv = 1.0 / sum(eval(1:nk))
   do k = 1, nk
      cumvar = sum(eval(1:k)) * totvar_inv
      if ( nm == 0 .and. cumvar >= var_threshold ) nm = k
   end do

   write(stdout,'(a,f15.5,i6)')' Threshold, truncation = ', var_threshold, nm

   open(10, file = 'be.vertloc.dat', status = 'unknown', form='unformatted')
   write(10) nk
   eval(:) = sqrt(eval(:)) ! Write out L^{1/2} for use in WRF-Var
   write(10)eval(1:nk)
   write(10)evec(1:nk,1:nk)

   close(10)

!------------------------------------------------------------------------------------------------
! Calculate B = E L E^T = U U^T [..00100..]
!------------------------------------------------------------------------------------------------

   ktarget = nk
   x(:) = 0.0
   x(ktarget) = 1.0

!  v = L^1/2 E^T x:
   do m = 1, nm
      v(m) = eval(m) * sum(evec(1:nk,m) * x(1:nk))
   end do

!  x = E L^1/2 v:
   do k = 1, nk
      x(k) = sum(evec(k,1:nm) * eval(1:nm) * v(1:nm))
!      write(22,'(i5,2f15.5)')k, rho(ktarget,k), x(k)
   end do

  deallocate(rho)
  deallocate(e)
  deallocate(cov)
  deallocate(eval)
  deallocate(evec)
  deallocate(v)
  deallocate(x)

end program gen_be_vertloc


      program main
c---- Целые числа от 2 до 100: решето Эратосфена
      integer prime (100)
c---- Обнулим prime
      do 10 n=2, 100
 10       prime (n) = 1
c---- Вычислим prime
      do 20 n=2, 100
          if (prime(n) .eq. 0) goto 20
              maxk = 100 / n
	      if (maxk .lt. 2) goto 20
              do 30 k=2, maxk
 30               prime (n*k) = 0
 20       continue
c---- Печать prime
      do 40 n=2, 100
 40       if (prime(n) .ne. 0) print 1000, n
      stop
 1000 format (1x, i4)
      end


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: ceiling_test1
subroutine ceiling_test1(i, a)
    integer :: i
    real :: a
    i = ceiling(a)
    ! CHECK: %[[f:.*]] = fir.call @llvm.ceil.f32
    ! CHECK: fir.convert %[[f]] : (f32) -> i32
  end subroutine
  ! CHECK-LABEL: ceiling_test2
  subroutine ceiling_test2(i, a)
    integer(8) :: i
    real :: a
    i = ceiling(a, 8)
    ! CHECK: %[[f:.*]] = fir.call @llvm.ceil.f32
    ! CHECK: fir.convert %[[f]] : (f32) -> i64
  end subroutine


C NCLFORTSTART
      subroutine xy2pdf77(nxy,x,y, xmsg,ymsg, nby, mbx, pdf
     *                   ,mbxp1,nbyp1,binxbnd, binybnd,ipcnt,ier)
      implicit none
      integer  nxy, nby, mbx, mbxp1, nbyp1, ipcnt,ier
      double precision x(nxy), y(nxy), xmsg, ymsg
     *                ,binxbnd(mbxp1), binybnd(nbyp1)
      double precision pdf(mbx,nby)
C NCLEND
      integer m, n, mb, nb, kxy, unit, msgflg

      ier = 0
      do nb=1,nby
        do mb=1,mbx
           pdf(mb,nb) = 0.0d0
        end do
      end do

      kxy = 0
      do n=1,nxy
         if (x(n).ne.xmsg .and. y(n).ne.ymsg) kxy = kxy + 1
      end do

c Valid data check

      if (kxy.eq.0) then
          ier = 1
          return
      end if

c Very large arrays can result in slow execution times.
c .   To minimize unnecessary do loop checks, see if missing
c .   values are present.

      msgflg = 1
      if (kxy.eq.nxy) msgflg = 0

c Binning

      if (msgflg.eq.1) then
          do nb=1,nby
            do mb=1,mbx
              do n=1,nxy
                 if (x(n).ne.xmsg .and. y(n).ne.ymsg) then
                     if (x(n).ge.binxbnd(mb)  .and.
     *                   x(n).lt.binxbnd(mb+1).and.
     *                   y(n).ge.binybnd(nb)  .and.
     *                   y(n).lt.binybnd(nb+1)) then
                         pdf(mb,nb) = pdf(mb,nb) + 1
                     end if
                 end if
              end do
            end do
          end do
      else
          do nb=1,nby
            do mb=1,mbx
               do n=1,nxy
                  if (x(n).ge.binxbnd(mb)  .and.
     *                x(n).lt.binxbnd(mb+1).and.
     *                y(n).ge.binybnd(nb)  .and.
     *                y(n).lt.binybnd(nb+1)) then
                      pdf(mb,nb) = pdf(mb,nb) + 1
                  end if
               end do
            end do
          end do
      end if

c change return units to % if flag set

      unit = 1
      if (ipcnt.eq.1) then
          unit = 100
      end if

      do nb=1,nby
        do mb=1,mbx
           pdf(mb,nb) = unit*(pdf(mb,nb)/kxy)
        end do
      end do

      return
      end


subroutine _compute_dev(sum_dev, a_dev, b_dev, c_dev)
    integer i,j,k
    REAL(8), dimension(100,100,100), intent(in) :: b_dev, c_dev
    REAL(8), dimension(100,100,100), intent(out) :: a_dev
    REAL(8), intent(inout) :: sum_dev
    integer :: nsize = 100

!$omp declare target
#define PDO
#ifdef PDO
!$omp parallel do
#endif
    do i=1,nsize
        do j=1,nsize
            do k=1,nsize
                a_dev(i,j,k) = b_dev(i,j,k) * c_dev(i,j,k) * i * nsize*nsize + j * nsize + k
            end do
        end do
    end do
end subroutine _compute_dev

program main
    integer :: nsize
    REAL(8) :: sum_dev = 0
    REAL(8), dimension(100,100,100) :: a_dev, b_dev, c_dev
    integer :: nsize = 100
!$omp declare target(_compute_dev)
    do i=1,nsize
        do j=1,nsize
            do k=1,nsize
                b_dev(i,j,k) = 1
                c_dev(i,j,k) = 2
            end do
        end do
    end do

!$omp target update to(b_dev,c_dev,sum_dev,nsize)
!$omp target
    CALL _compute_dev(sum_dev, a_dev, b_dev, c_dev)
!$omp end target
!$omp target update from(a_dev,sum_dev)

    do i=1,3
        do j=1,3
            do k=1,3
                print *, a_dev(i,j,k)
            end do
        end do
    end do
end program main


      FUNCTION   PROB_TO_SIGMA (plvl)

c***********************************************************************
c                         function   prob_to_sigma
c***********************************************************************

c  Program Source:   Naval Ocean Systems Center - Code 542

c  Date:
c     12 Feb 1991

c  Function:
c     Determines the number of standard deviations to use for specific
c     probabilities

c  Parameters passed:
c     plvl           [r,1] probability level expressed as percentage

c  Parameters returned:
c     prob_to_sigma  [r,1] number of standard deviations from the mean
c                          corresponding to the probability

c  Common blocks referenced:

c  Functions and subroutines referenced:
c     abs

c     erfc

c  References:

c  Change History:
c     22 Jan 1992    Reduced tolerance for terminating the iterations.

c     50 Jun 1995    Added tests for 0% and 100%.

c********************!**************************************************

      if (     plvl .eq.   0.) then
         t1=-100.
      else
     &if (plvl .eq.  50.) then
         t1=0.
      else
     &if (plvl .eq.  84.) then
         t1=1.
      else
     &if (plvl .eq.  90.) then
         t1=1.28
      else
     &if (plvl .eq.  99.) then
         t1=2.33
      else
     &if (plvl .eq. 100.) then
         t1=100.
      else
         t2=1.28
         f2=90.
         t1=1.
         f1=84.
Change:              This used to be .1
         do while (ABS(plvl-f1) .gt. .001)
            t=(t2-t1)*(plvl-f1)/(f2-f1)+t1
            t2=t1
            f2=f1
            t1=t
            f1=50.*(2.-ERFC(t1*.707107))
         end do
      end if
      prob_to_sigma=t1

      RETURN
      END      ! PROB_TO_SIGMA


function userfunc(x, y) result(func)

  implicit none

  real(8) :: x, y, func

  func = sin(x + y)

end function userfunc


program sch1d_time_prop

! Implements time propagation for a 1D Schroedinger equation.

use types, only: dp
use constants, only: i_, pi
use ofdft, only: read_pseudo
use ofdft_fft, only: free_energy, radial_potential_fourier, &
    reciprocal_space_vectors, free_energy_min, real2fourier, integral, &
    fourier2real, real_space_vectors, vtk_save
use utils, only: loadtxt, stop_error, assert, linspace, strfmt
use splines, only: spline3pars, iixmin, poly3, spline3ders
use interp3d, only: trilinear
use md, only: positions_fcc, positions_bcc
implicit none
integer :: Ng
real(dp), allocatable :: G(:), G2(:)
real(dp), allocatable :: ne(:)
real(dp), allocatable :: Xn(:), Vn(:)
complex(dp), allocatable, dimension(:) :: psi, psiG
complex(dp), allocatable, dimension(:) :: dpsi
real(dp) :: L
integer :: i
integer, parameter :: nelec = 1
real(dp) :: dt, psi_norm
integer :: u
real(dp) :: t

Ng = 2048

L = 10._dp

allocate(ne(Ng))
allocate(G(Ng), G2(Ng), psi(Ng))
allocate(psiG(Ng))
allocate(dpsi(Ng))
allocate(Xn(Ng), Vn(Ng))

call real_space_vectors(L, Xn)
call reciprocal_space_vectors(L, G, G2)
Vn = 1e5_dp*(Xn-L/2)**2
psi = gauss_x(Xn, 0.1_dp, L/2, 400._dp)

dt = 1e-4_dp
print *, "dt =", dt

open(newunit=u, file="sch1d.txt", status="replace")
close(u)

open(newunit=u, file="sch1d_grid.txt", status="replace")
write(u, *) Xn
write(u, *) Vn
close(u)

open(newunit=u, file="sch1d_psi.txt", status="replace")
write(u, *) real(psi, dp), aimag(psi)
close(u)

! Do first step by hand:
print *, "First step"
ne = real(psi*conjg(psi), dp)
psi_norm = integral(L, ne)
print *, "Initial norm of psi:", psi_norm
psi = sqrt(nelec / psi_norm) * psi
ne = real(psi*conjg(psi), dp)
psi_norm = integral(L, ne)
print *, "norm of psi:", psi_norm

t = 0

do i = 1, 100
    t = t + dt
    print *, "iter =", i, "time =", t

    psi = psi * exp(-i_*Vn*dt/2)
    call real2fourier(psi, psiG)
    psiG = psiG * exp(-i_*G2*dt/2)
    call fourier2real(psiG, psi)
    psi = psi * exp(-i_*Vn*dt/2)

    ne = real(psi*conjg(psi), dp)
    psi_norm = integral(L, ne)
    print *, "norm of psi:", psi_norm

    open(newunit=u, file="sch1d.txt", position="append", status="old")
    write(u, *) i, t, psi_norm
    close(u)

    open(newunit=u, file="sch1d_psi.txt", position="append", status="old")
    write(u, *) real(psi, dp), aimag(psi)
    close(u)

end do
print *, "Done"

contains

    pure function gauss_x(x, a, x0, k0) result(r)
    real(dp), intent(in) :: x(:), a, x0, k0
    complex(dp) :: r(size(x))
    r = (a * sqrt(pi))**(-0.5_dp) &
            * exp(-0.5_dp * ((x - x0) / a)**2 + i_ * x * k0)
    end function

end program


! Copyright 2015 Dennis Decker Jensen
! The gas station problem. A classic computer sicence problem.
! http://programmingpraxis.com/2015/07/17/the-gas-station-problem/

! There is a circular route for a truck.
! The truck has a gas tank with infinite capacity.
! Along the route are gas stations with varying amount of gas
! available: You are given a list of gas stations with amounts
! of gas available, and another list with gas required to go
! to the next gas station. You must find the start gas station
! that makes it possible to complete a circular trip back to start
! without the truck running out of gas.
program gas
   implicit none
   integer, dimension(8) :: trip, gasoline, distance
   integer start

   gasoline = (/15, 08, 02, 06, 18, 09, 21, 30/)
   distance = (/08, 06, 30, 09, 15, 21, 02, 18/)
   call station(gasoline, distance, trip, start)
   print 100, start, trip
   call station2(gasoline, distance, start)
   print '(A,I2)', "Trip start (solution 2): ", start

   gasoline(8) = gasoline(8) - 1 ! Make trip impossible
   call station(gasoline, distance, trip, start)
   print 100, start, trip
   call station2(gasoline, distance, start)
   print '(A,I2)', "Trip start (solution 2): ", start
100 format ('Station start: ',I2,'; trip:',8I4)

contains

   ! Take the cumulative sum of the excess fuel.
   ! The solution is the station after the station
   !  where the excess fuel is the most negative.
   subroutine station(gas, distance, trip, start)
      integer, intent(in) :: gas(:), distance(size(gas))
      integer, intent(out) :: trip(size(gas)), start
      integer i, m(1)

      trip = gas - distance
      call accumulate(trip)

      if (trip(size(trip)) < 0) then
         start = 0 ! There is not enough fuel for the trip
         ! Leave trip alone for debugging
      else
         m = minloc(trip)
         start = modulo(m(1) + 1, size(trip)) ! Right after the least
         trip = gas - distance
         trip = (/trip(start:), trip(1:start - 1)/)
         call accumulate(trip)
      end if
   end subroutine station

   subroutine accumulate(a)
      integer a(:), i
      do i = 2, size(a)
         a(i) = a(i) + a(i - 1)
      end do
   end subroutine accumulate

   ! Sum up the addition of excess fuel,
   ! and move start backwards if there is not enough gas in tank.
   subroutine station2(gas, distance, start)
      integer, intent(in) :: gas(:), distance(size(gas))
      integer, intent(out) :: start
      integer i, tank

      start = size(gas) + 1
      i = 1
      tank = 0
      do while (i < start)
         if (tank + gas(i) >= distance(i)) then
            tank = tank + gas(i) - distance(i)
            i = i + 1
         else
            start = start - 1
            tank = tank + gas(start) - distance(start)
         end if
      end do
      if (tank >= 0) then
         start = modulo(start, size(gas))
      else
         start = 0
      end if
   end subroutine station2
end program gas


      subroutine setprob()
      implicit none

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision tperiod
      common /comvt/ tperiod

      pi = 4.d0*datan(1.d0)
      pi2 = 2.d0*pi

      open(10,file='setprob.data')
      read(10,*) tperiod
      close(10)

      end


! vectorspace.f90 --
!     Define a module for dealing with vector spaces in an abstract sense
!
!     The basic data type is an abstract vector, with the following
!     operations:
!     "+" - to add two vectors to get a new vector
!     "*" - to multiply a vector with a scalar
!     We can use an array of vectors as a collection: the operation ".in."
!     determines if a given vector is in that collection.
!
!     Note:
!     The multiplication does not work as I want, because I need a PASS attribute
!     and that conflicts with some restriction.
!
!     Attempt without abstract type
!
module vectorspaces
    implicit none

    type :: vector
    end type vector

    interface operator(+)
        module procedure addition
    end interface

    interface operator(*)
        module procedure multiplication
    end interface

    interface operator(.in.)
        module procedure membership
    end interface

contains
function addition( a, b )
    class(vector), intent(in)  :: a
    class(vector), intent(in)  :: b
    class(vector), allocatable :: addition

    allocate( addition )
end function addition

! Note: the other way around, did not work :(
function multiplication( a, b )
    real, intent(in)           :: a
    class(vector), intent(in)  :: b
    class(vector), allocatable :: multiplication

    allocate( multiplication )
end function multiplication

function membership( a, b )
    class(vector), intent(in)               :: a
    class(vector), intent(in), dimension(:) :: b
    logical                                 :: membership

    membership = .false.
end function membership

end module vectorspaces

!
! Test this with an actual implementation
!
module vectors_3d
    use vectorspaces

   ! type, extends(vector) :: vector_3d
    type :: vector_3d
        real, dimension(3) :: coords
    end type

    interface operator(+)
        module procedure add_3d
    end interface

    interface operator(*)
        module procedure multiply_3d
    end interface

    interface operator(.in.)
        module procedure is_member_3d
    end interface

contains
function add_3d( a, b )
    type(vector_3d), intent(in)  :: a
    type(vector_3d), intent(in)  :: b
    type(vector_3d)              :: add_3d

    add_3d%coords = a%coords + b%coords
end function add_3d

function multiply_3d( a, b )
    real, intent(in)             :: a
    type(vector_3d), intent(in)  :: b
    type(vector_3d)              :: multiply_3d

    multiply_3d%coords = a * b%coords
end function multiply_3d

logical function is_member_3d( a, b )
    type(vector_3d), intent(in)               :: a
    type(vector_3d), intent(in), dimension(:) :: b

    integer                                   :: i

    is_member_3d = .false.

    do i = 1,size(b)
        if ( all( a%coords == b(i)%coords ) ) then
            is_member_3d = .true.
            exit
        endif
    enddo
end function is_member_3d

! coords --
!     To print the resulting vector, use a "getter"
!
function coords( a )
    type(vector_3d), intent(in) :: a
    real, dimension(3)          :: coords

    coords = a%coords
end function coords

end module vectors_3d

! Test program for the vector space modules
!
! Note:
!     To keep the program small, there is no facility to manipulate a collection
!     of vectors, but you could add that too.
!
program test_space
    use vectors_3d

    implicit none

    type(vector_3d)                :: a, b, c
    type(vector_3d), dimension(10) :: vectors

    a = vector_3d( [1.0, 1.0, 1.0] )
    b = vector_3d( [2.0, 2.0, 2.0] )
    c = vector_3d( [3.0, 3.0, 3.0] )

    vectors = vector_3d( [0.0, 0.0, 0.0] ) ! Primitive initialisation

    vectors(1) = a
    vectors(2) = b

    write(*,*) 'Is a in the collection? ', a .in. vectors
    write(*,*) 'Is c in the collection? ', c .in. vectors

    vectors(3) = a + b
    write(*,*) 'Added the sum of a and b - should be equal to c'
    write(*,*) 'Is c in the collection? ', c .in. vectors

    write(*,*) 'a + b  = ', coords(a + b)
    write(*,*) '10 * c = ', coords(10.0 * c)

end program test_space


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

      subroutine tcalc(avgstemp, teff, tfunc)

      implicit none

c ... Argument declarations
      double precision avgstemp, teff(4), tfunc

c ... This function computes the effect of temperature on
c ... decomposition.  It is an exponential function.  Older
c ... versions of Century used a density function.
c ... Created 10/95 - rm
c ...
c ... The temperature effect is now being computed using an
c ... arctangent curve.  CAK - 03/16/01
c ...
c ... Called From:  calcdefac
c ...
c ... Variables
c ...   AVGSTEMP:  weighted average of the average soil temperature in
c ...              the second and third soil layers
c ...   TEFF(1):   "x" location of inflection point
c ...   TEFF(2):   "y" location of inflection point
c ...   TEFF(3):   step size (distance from the maximum point to the
c ...              minimum point)
c ...   TEFF(4):   slope of line at inflection point

c ... Allow C code to call Fortran function
c      !MS$ATTRIBUTES C :: tcalc

c ... Function declarations
      double precision catanf
      external  catanf

c ... Local variables
      double precision normalizer

c ... The normalizer is the value of the numerator at 30 deg C
      normalizer = catanf(30.0, teff(1), teff(2), teff(3), teff(4))

      tfunc = max(0.01,
     &            catanf(avgstemp, teff(1), teff(2), teff(3), teff(4)) /
     &            normalizer)

c     write(*,*) 'normalizer = ', normalizer
c     write(*,*) 'tfunc = ', tfunc
      return
      end


C-----------------------------------------------------------------------
      SUBROUTINE SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
     &                   IP,IS,JN,JS,KW,KG,JB,JE,JC,
     &                   WAVE,GRIDN,GRIDS,IDIR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPTRAN     PERFORM A SCALAR SPHERICAL TRANSFORM
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-29
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM
C           BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES
C           AND FIELDS ON A GLOBAL CYLINDRICAL GRID.
C           THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
C           THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID
C           (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID.
C           THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING,
C           BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER',
C           I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX.
C           TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY;
C           THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED.
C           IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS
C           MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM.
C           THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT
C           THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED
C           OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY.
C           TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
C           SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C PROGRAM HISTORY LOG:
C   96-02-29  IREDELL
C 1998-12-15  IREDELL  GENERIC FFT USED
C                      OPENMP DIRECTIVES INSERTED
C 2013-01-16  IREDELL &
C	      MIRVIS    ::
C			FIXING AFFT NEGATIVE SHARING EFFECT DURING
C			OMP LOOPS BY CREATING TMP AFFT COPY (AFFT_TMP)
C			TO BE PRIVATE DURING OMP LOOP THREADING
C
C USAGE:    CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
C    &                   IP,IS,JN,JS,KW,KG,JB,JE,JC,
C    &                   WAVE,GRIDN,GRIDS,IDIR)
C   INPUT ARGUMENTS:
C     IROMB    - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     MAXWV    - INTEGER SPECTRAL TRUNCATION
C     IDRT     - INTEGER GRID IDENTIFIER
C                (IDRT=4 FOR GAUSSIAN GRID,
C                 IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
C                 IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
C     IMAX     - INTEGER EVEN NUMBER OF LONGITUDES.
C     JMAX     - INTEGER NUMBER OF LATITUDES.
C     KMAX     - INTEGER NUMBER OF FIELDS TO TRANSFORM.
C     IP       - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN
C     IS       - INTEGER SKIP NUMBER BETWEEN LONGITUDES
C     JN       - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH
C     JS       - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH
C     KW       - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS
C     KG       - INTEGER SKIP NUMBER BETWEEN GRID FIELDS
C     JB       - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM
C     JE       - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM
C     JC       - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
C     WAVE     - REAL (*) WAVE FIELDS IF IDIR>0
C     GRIDN    - REAL (*) N.H. GRID FIELDS (STARTING AT JB) IF IDIR<0
C     GRIDS    - REAL (*) S.H. GRID FIELDS (STARTING AT JB) IF IDIR<0
C     IDIR     - INTEGER TRANSFORM FLAG
C                (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE)
C   OUTPUT ARGUMENTS:
C     WAVE     - REAL (*) WAVE FIELDS IF IDIR<0
C     GRIDN    - REAL (*) N.H. GRID FIELDS (STARTING AT JB) IF IDIR>0
C     GRIDS    - REAL (*) S.H. GRID FIELDS (STARTING AT JB) IF IDIR>0
C
C SUBPROGRAMS CALLED:
C   SPTRANF0     SPTRANF SPECTRAL INITIALIZATION
C   SPTRANF1     SPTRANF SPECTRAL TRANSFORM
C
C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
C   DIMENSION                    LINEAR              QUADRATIC
C   -----------------------      ---------           -------------
C   IMAX                         2*MAXWV+2           3*MAXWV/2*2+2
C   JMAX (IDRT=4,IROMB=0)        1*MAXWV+1           3*MAXWV/2+1
C   JMAX (IDRT=4,IROMB=1)        2*MAXWV+1           5*MAXWV/2+1
C   JMAX (IDRT=0,IROMB=0)        2*MAXWV+3           3*MAXWV/2*2+3
C   JMAX (IDRT=0,IROMB=1)        4*MAXWV+3           5*MAXWV/2*2+3
C   JMAX (IDRT=256,IROMB=0)      2*MAXWV+1           3*MAXWV/2*2+1
C   JMAX (IDRT=256,IROMB=1)      4*MAXWV+1           5*MAXWV/2*2+1
C   -----------------------      ---------           -------------
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      REAL WAVE(*),GRIDN(*),GRIDS(*)
      REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
      REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
      REAL(8) AFFT(50000+4*IMAX), AFFT_TMP(50000+4*IMAX)
      REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE)
      REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE)
      REAL PLNTOP(MAXWV+1,JB:JE)
      REAL WTOP(2*(MAXWV+1))
      REAL G(IMAX,2)
!      write(0,*) 'sptranf top'
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SET PARAMETERS
      MP=0
      CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE,
     &              EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
     &              AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSFORM WAVE TO GRID
      IF(IDIR.GT.0) THEN
C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,WTOP,G,IJKN,IJKS)
        DO K=1,KMAX
			  AFFT_TMP=AFFT
          KWS=(K-1)*KW
          WTOP=0
          DO J=JB,JE
            CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
     &                    EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
     &                    AFFT_TMP,CLAT(J),SLAT(J),WLAT(J),
     &                    PLN(1,J),PLNTOP(1,J),MP,
     &                    WAVE(KWS+1),WTOP,G,IDIR)
            IF(IP.EQ.1.AND.IS.EQ.1) THEN
              DO I=1,IMAX
                IJKN=I+(J-JB)*JN+(K-1)*KG
                IJKS=I+(J-JB)*JS+(K-1)*KG
                GRIDN(IJKN)=G(I,1)
                GRIDS(IJKS)=G(I,2)
              ENDDO
            ELSE
              DO I=1,IMAX
                IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1
                IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1
                GRIDN(IJKN)=G(I,1)
                GRIDS(IJKS)=G(I,2)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSFORM GRID TO WAVE
      ELSE
C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,WTOP,G,IJKN,IJKS)
        DO K=1,KMAX
			  AFFT_TMP=AFFT
          KWS=(K-1)*KW
          WTOP=0
          DO J=JB,JE
            IF(WLAT(J).GT.0.) THEN
              IF(IP.EQ.1.AND.IS.EQ.1) THEN
                DO I=1,IMAX
                  IJKN=I+(J-JB)*JN+(K-1)*KG
                  IJKS=I+(J-JB)*JS+(K-1)*KG
                  G(I,1)=GRIDN(IJKN)
                  G(I,2)=GRIDS(IJKS)
                ENDDO
              ELSE
                DO I=1,IMAX
                  IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1
                  IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1
                  G(I,1)=GRIDN(IJKN)
                  G(I,2)=GRIDS(IJKS)
                ENDDO
              ENDIF
              CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
     &                      EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
     &                      AFFT_TMP,CLAT(J),SLAT(J),WLAT(J),
     &                      PLN(1,J),PLNTOP(1,J),MP,
     &                      WAVE(KWS+1),WTOP,G,IDIR)
            ENDIF
          ENDDO
        ENDDO
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
cc
      subroutine dirft2d1(nj,xj,yj,cj, iflag, ms,mt,fk)
      implicit none
      integer nj, iflag, ms, mt
      real*8 xj(nj), yj(nj)
      complex*16 cj(nj), fk(-ms/2:(ms-1)/2,-mt/2:(mt-1)/2)
c     ------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c                  1  nj
c     fk(k1,k2) = -- SUM cj(j) exp(+/-i k1 xj(j)) exp(+/-i k2 yj(j))
c                 nj j=1
c
c     for -ms/2 <= k1 <= (ms-1)/2, -mt/2 <= k2 <= (mt-1)/2
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
c***********************************************************************
      integer j, k1, k2
      complex*16 zf, cm1, z1n(-ms/2:(ms-1)/2)
c
      do k2 = -mt/2, (mt-1)/2
         do k1 = -ms/2, (ms-1)/2
            fk(k1,k2) = dcmplx(0d0,0d0)
         enddo
      enddo
c
      do j = 1, nj
c
c     ----------------------------------------------------------
c     Precompute exponential for exp(+/-i k1 xj)
c     ----------------------------------------------------------
c
         if (iflag .ge. 0) then
            zf = dcmplx(dcos(xj(j)),+dsin(xj(j)))
         else
            zf = dcmplx(dcos(xj(j)),-dsin(xj(j)))
         endif
         z1n(0) = (1d0,0d0)
         do k1 = 1, (ms-1)/2
            z1n(k1) = zf*z1n(k1-1)
            z1n(-k1)= dconjg(z1n(k1))
         enddo
         if (ms/2*2.eq.ms) z1n(-ms/2) = dconjg(zf*z1n(ms/2-1))
c
c     ----------------------------------------------------------
c     Loop over k2 for yj
c     ----------------------------------------------------------
         if (iflag .ge. 0) then
            zf = dcmplx(dcos(yj(j)),+dsin(yj(j)))
         else
            zf = dcmplx(dcos(yj(j)),-dsin(yj(j)))
         endif
c
         cm1 = cj(j) / dble(nj)
         do k2 = 0, (mt-1)/2
            do k1 = -ms/2, (ms-1)/2
              fk(k1,k2) = fk(k1,k2) + cm1*z1n(k1)
            enddo
            cm1 = cm1*zf
         enddo
c
         zf = dconjg(zf)
         cm1 = cj(j) / dble(nj)
         do k2 = -1, -mt/2, -1
            cm1 = cm1*zf
            do k1 = -ms/2, (ms-1)/2
              fk(k1,k2) = fk(k1,k2) + cm1*z1n(k1)
            enddo
         enddo
      enddo
      end
c
c
c
c
c
c************************************************************************
      subroutine dirft2d2(nj,xj,yj,cj, iflag, ms,mt,fk)
      implicit none
      integer nj, iflag, ms, mt
      real*8 xj(nj), yj(nj)
      complex*16 cj(nj), fk(-ms/2:(ms-1)/2,-mt/2:(mt-1)/2)
c     ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c
c     cj(j) = SUM  SUM  fk(k1,k2) exp(+/-i k1 xj(j)) exp(+/-i k2 yj(j))
c             k1   k2
c
c                            for j = 1,...,nj
c
c     where -ms/2 <= k1 <= (ms-1)/2, -mt/2 <= k2 <= (mt-1)/2
c
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
************************************************************************
      integer j, k1, k2
      complex*16 zf, cm1, cm2, z1n(-ms/2:(ms-1)/2)
c
      do j = 1, nj
c
c     ----------------------------------------------------------
c     Precompute exponential for exp(+/-i k1 xj)
c     ----------------------------------------------------------
         if (iflag .ge. 0) then
            zf = dcmplx(dcos(xj(j)),+dsin(xj(j)))
         else
            zf = dcmplx(dcos(xj(j)),-dsin(xj(j)))
         endif
         z1n(0) = (1d0,0d0)
         do k1 = 1, (ms-1)/2
            z1n(k1) = zf*z1n(k1-1)
            z1n(-k1)= dconjg(z1n(k1))
         enddo
         if (ms/2*2.eq.ms) z1n(-ms/2) = dconjg(zf*z1n(ms/2-1))
         if (iflag .ge. 0) then
            zf = dcmplx(dcos(yj(j)),+dsin(yj(j)))
         else
            zf = dcmplx(dcos(yj(j)),-dsin(yj(j)))
         endif
c
         cm1 = (0d0, 0d0)
         do k1 = -ms/2, (ms-1)/2
           cm1 = cm1 + z1n(k1) * fk(k1,0)
         enddo
         cj(j) = cm1
c
c     ----------------------------------------------------------
c     Loop over k2 for yj
c     ----------------------------------------------------------
c
         cm2 = zf
         do k2 = 1, (mt-1)/2
            cm1 = (0d0, 0d0)
            do k1 = -ms/2, (ms-1)/2
              cm1 = cm1 + z1n(k1) * fk(k1,k2)
            enddo
            cj(j) = cj(j) + cm2 * cm1

            cm1 = (0d0, 0d0)
            do k1 = -ms/2, (ms-1)/2
              cm1 = cm1 + z1n(k1) * fk(k1,-k2)
            enddo
            cj(j) = cj(j) + dconjg(cm2) * cm1
            cm2 = cm2*zf
         enddo
c
         if (mt/2*2.eq.mt) then
            cm1 = (0d0, 0d0)
            do k1 = -ms/2, (ms-1)/2
              cm1 = cm1 + z1n(k1) * fk(k1,-mt/2)
            enddo
            cj(j) = cj(j) + dconjg(cm2) * cm1
         endif

      enddo
      end

************************************************************************
      subroutine dirft2d3(nj,xj,yj,cj, iflag, nk,sk,tk,fk)
      implicit none
      integer nj, iflag, nk
      real*8 xj(nj), yj(nj), sk(nk), tk(nk)
      complex*16 cj(nj), fk(nk)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c              nj
c     fk(k) = SUM cj(j) exp(+/-i s(k) xj(j)) exp(+/-i t(k) yj(j))
c             j=1
c
c                    for k = 1, ..., nk
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
************************************************************************
      integer k, j
      real*8 ssk, stk
c
      do k = 1, nk
         if (iflag .ge. 0) then
            ssk =  sk(k)
            stk =  tk(k)
         else
            ssk =  -sk(k)
            stk =  -tk(k)
         endif
c
         fk(k) = dcmplx(0d0,0d0)
         do j = 1, nj
            fk(k) = fk(k) + cj(j) * dcmplx
     &        ( dcos(ssk*xj(j)+stk*yj(j)), dsin(ssk*xj(j)+stk*yj(j)) )
         enddo
      enddo
      end


SUBROUTINE VerticalFreeSurfaceVelocity(W,Nx,Ny,Nz,sol,DiffStencils,dsdz,gamma)
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
TYPE (Diff_def), INTENT(IN) :: DiffStencils
INTEGER :: Nx, Ny, Nz, gamma, i, j
REAL(KIND=long), DIMENSION(Nz,Nx,Ny), INTENT(IN) :: dsdz, sol
REAL(KIND=long), DIMENSION(Nx,Ny), INTENT(OUT) :: W
INTEGER, DIMENSION(2*gamma+1) :: idx
DO i = 1, 2*gamma+1
  idx(i) = Nz-2*gamma + i - 1
END DO
DO j = 1, Ny
  DO i = 1, Nx
    ! Determine for free surface points only
	W(i,j) = dsdz(Nz,i,j)*DOT_PRODUCT(DiffStencils%StencilZ(Nz,:,1),sol(idx,i,j))
  END DO
END DO
END SUBROUTINE VerticalFreeSurfaceVelocity


!
!===============================================================================
!-- Elasticity Module
!> Module contains routines specifically related to elasticity equations
!===============================================================================
!/****/h* modules|phy_elasticity/elasticity_mod
MODULE elasticity_mod
!* PURPOSE
!*   Module contains routines specifically related to elasticity equations
!* INCLUDES
!*   Name                    Purpose
!*   common_mod              variable definitions
!* CONTAINS
!*   Subroutine              Purpose
!*   deemat_linelasticity    create material matrix for linear elasticity
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2022/04/30: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2022/04/30
!> Module contains routines specifically related to elasticity equations
!===============================================================================

  !-- use statements and implicit none --
  USE common_mod

  IMPLICIT NONE

!===============================================================================
CONTAINS
!===============================================================================
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* elasticity_mod/deemat_linelasticity
!* SYNOPSIS
  SUBROUTINE deemat_linelasticity(dee,e,v)
!* PURPOSE
!*   Compute the material matrix (D-matrix) for a linear elastic material.
!* AUTHOR
!*   Pieter Boom (adapted from parafem deemat subroutine)
!* MODIFICATION HISTORY
!*   2020/09/16: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom (adapted from parafem deemat subroutine)
!> date: 2020/09/16
!> Compute the material matrix (D-matrix) for a linear elastic material.
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  IMPLICIT NONE

  !-- arguments and local variables --
  REAL(KIND=PGMSiwp),INTENT(IN)    :: e,v
  REAL(KIND=PGMSiwp),INTENT(INOUT) :: dee(:,:)
  REAL(KIND=PGMSiwp)               :: v2,vv
  REAL(KIND=PGMSiwp),PARAMETER     :: zero=0.d0,one=1.d0,two=2.d0
  INTEGER                 :: i

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    dee = zero; vv = v*e/(one-2*v)/(one+v); v2 = e/(two+two*v)
    DO i=2,4; dee(i,i)=v2; END DO
    DO i=6,8; dee(i,i)=v2; END DO
    DO i=1,9,4
      dee(i,(/ 1,5,9 /)) = vv
      dee(i,i) = dee(i,i) + 2*v2
    END DO
    dee(2,4) = v2; dee(3,7) = v2; dee(4,2) = v2
    dee(6,8) = v2; dee(7,3) = v2; dee(8,6) = v2

  END SUBROUTINE
! elasticity_mod/deemat_linelasticity
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!

END MODULE
! elasticity_mod
!===============================================================================
!


! RDIST, Python FORTRAN module (f2py compliant)
! Copyright Alfredo Metere, 2012-06-17. All Rights Reserved
!
! This code is published with an LGPL License.
! Further informations here ( PUT THE LGPL LICENSE INFO )
!
! For info: alfredo.metere@mmk.su.se
!           alfredo.metere@molworx.com
!
! Abstract:
! --------
!
! This routine calculates a radial distribution of a particle set and outputs
! it in a table [r; i], where r is the particle-particle distance and i is the
! number of particles at that distance from other particles.
!
! ------------------------------------------------------------------------------
subroutine rdist(n, nbins, vp, rcut, rdf_y, rdf_x)

    implicit none
! n                      = Number of particles
! vp                     = Array storing particles positions
! rd_tbl	             = Radial Distribution Table
! d_mode	             = Number of decimals digits on the distances
! xj, yj, zj, xi, yi, zi = Variables storing particles coordinates for the loop
!                          generating the neighbor list
! dx, dy, dz, mdl        = Variables used for computing vector modulus
! m, i, j                = Neighbour list array size and counters
! rpn                    = Restricted table particle numbers

    integer*4, intent(in)                            :: n
    integer*4, intent(in)                            :: nbins !, d_mode
    real*8, intent(in), dimension(n,3)               :: vp
    real*8, intent(in)                               :: rcut

    real*8, parameter                                :: pi = 3.141592654

    real*8, dimension(nbins*nbins)                   :: rdf_y2
    real*8, dimension(nbins), intent(out)            :: rdf_y
    real*8, dimension(nbins), intent(out)            :: rdf_x

    real*8                                           :: cmax, cmin, ctemp
    real*8                                           :: cval, drr
    real*8                                           :: xj,yj,zj
    real*8                                           :: xi,yi,zi
    real*8                                           :: xmax,ymax,zmax
    real*8                                           :: xmin,ymin,zmin
    real*8                                           :: xbox, ybox, zbox
    real*8                                           :: xb2, yb2, zb2
    real*8                                           :: dx,dy,dz,dr,mdl, dn
    real*8                                           :: rho, mdlbox
    integer*4                                        :: i,j,k,kk, nn
    integer*4                                        :: m, i1, i2

    integer*2                                        :: m2(4)

    equivalence (mdl,m2(1)),(m2(3),m)
! Processes all the unique particle couples and calculates their distances
    k = 0

! Needed now

    !pi = 3.141592654
!    m = (n**2 - n)

!    print *, "Number of particles (N) = ", size(vp)/3
!    print *, "Number of unique pairs (M) = ", (n*n)
!    if(size(couples)/3 .eq. m) then
!        print *, "M size is correct"
!    else
!        print *, "Some error must be occurred"
!        print *, "M ", m
!        stop
!    end if

    print *,"Determining system boundaries"

    xmin   = 0.0
    ymin   = 0.0
    zmin   = 0.0
    xmax   = 0.0
    ymax   = 0.0
    zmax   = 0.0

    cval   = 0.0
    rdf_x  = 0.0
    rdf_y  = 0.0
    rdf_y2 = 0.0
    cmin   = 0.0

    nn     = 0.0
    dn     = 2.0 / n

    do i=1, n
        if (vp(i,1) > xmax) xmax = vp(i,1)
        if (vp(i,2) > ymax) ymax = vp(i,2)
        if (vp(i,3) > zmax) zmax = vp(i,3)

        if (vp(i,1) < xmin) xmin = vp(i,1)
        if (vp(i,2) < ymin) ymin = vp(i,2)
        if (vp(i,3) < zmin) zmin = vp(i,3)
    end do
    print *,"Absolute boundaries of the system"
    write(6,'(a4,f10.6,a5,f10.6,a5,f10.6)') "X0: ",xmin," Y0: ",ymin," Z0: ",zmin
    write(6,'(a4,f10.6,a5,f10.6,a5,f10.6)') "X1: ",xmax," Y1: ",ymax," Z1: ",zmax

    xbox = xmax - xmin
    ybox = ymax - ymin
    zbox = zmax - zmin

    rho = n / (xbox*ybox*zbox)

    xb2 = xbox / 2.
    yb2 = ybox / 2.
    zb2 = zbox / 2.

    mdlbox = xb2 * xb2 + yb2 * yb2 + zb2 * zb2

    ctemp = rcut/float(nbins)
    !ctemp = sqrt(mdlbox)/float(nbins)
    write(6,'(a6,f15.8)'), "Step: ", ctemp

    do i=1,nbins
        rdf_x(i) = i * ctemp
        !rdf_x(i) = (n/rho)**(1./3.) * (i-0.5)
    end do

    print *,"Box size"
    print *,"RHO: ",rho
    write(6,'(a5,f10.6,a1,f10.6,a1,f10.6,a1)') "XYZ (",xbox,",",ybox,",",zbox,")"

    open (8, file = 'restricted_rd.csv', access = 'sequential', status = 'replace', form = 'formatted')

    print *,"Computing particle neighbours"
    do i = 1, (n - 1)
        xi = vp(i,1)
        yi = vp(i,2)
        zi = vp(i,3)

        do j = 1, n
            if (i .ge. j) cycle

            xj = vp(j,1)
            yj = vp(j,2)
            zj = vp(j,3)

            dx = abs(xj - xi)
            dy = abs(yj - yi)
            dz = abs(zj - zi)

	    !dx = xj - xi
            !dy = yj - yi
            !dz = zj - zi

	    ! these are added
	    !if (dx .gt. xb2) dx = xbox - dx
	    !if (dy .gt. yb2) dy = ybox - dy
	    !if (dz .gt. zb2) dz = zbox - dz

        !mdl = sqrt(dx*dx + dy*dy + dz*dz)
	    mdl = sqrt(dx*dx + dy*dy + dz*dz)
        if (mdl .lt. 1.) print *,mdl

	    !if (mdl .ge. mdlbox/2) mdl = mdl - mdlbox/2

            if (mdl .gt. rcut) then! (mdl .ge. rcut)
                cycle

            !    rdf_y(m) = rdf_y(m) + (2./n)
            !end if
            else
    !            m = int(mdl) + 1
            !print *,"m = int(mdl) + 1",m
                ! Slides the whole  RDF histogram
                do k = 1,nbins
                    cval = rdf_x(k) + ctemp
                    cmin = rdf_x(k) - ctemp
                    if (mdl >= cmin .and. mdl <= cval) then
			 ! nn Counts how many couples fall in the cutoff radius.
			 !    It is needed to normalize the histogram values
	!		 nn = nn + 1.0
		                rdf_y(k) = rdf_y(k) + 1.0
                    end if
                end do

             end if
             !m = int(mdl) + 1
             !rdf_y2(m)=rdf_y2(m) + dn
        end do
    end do

!    do i = 1, nbins
!        rdf_y(i) = 0.
!        i1 = (i-1)**2 + 1
!        i2 = i**2
!        do j = i1, i2
!             rdf_y(i) = rdf_y(i) + rdf_y2(j)
!        end do
!    end do

    do k = 1,nbins
    cval = rdf_x(k) + ctemp
    cmin = rdf_x(k) - ctemp
	!cval = 1. *  k
	!cmin = 1. * (k-1)
	drr = cval*cval*cval - cmin*cmin*cmin
	dr = rho * 4.0 * pi * drr / 3.0
! Normalizes to a spherical shell the bin values to avoid recurrencies
!        rdf_y(k) = rdf_y(k) / (4.0 / 3.0 * pi * (cval**3 - cmin**3))
	rdf_y(k) = rdf_y(k) / dr
	!rdf_y(k) = (rdf_y(k) / nn) / (4.0 / 3.0 * pi * dr) * rho
	!rdf_y(k) = rdf_y(k) * rho
    end do

    write (*,*)
    print *,"Done"

! Writes a CSV file containing the RDF plot coordinates
    open (7, file = 'full_rd.csv', access = 'sequential', status = 'replace', form = 'formatted')
    print *,"Exporting CSV file (full_rd.csv)"
    do k = 1, nbins
        write(7,'(f15.4,a1,f15.4)') rdf_x(k),',',rdf_y(k)
    end do
    print *,"Done"
    close(7)
    close(8)

end subroutine rdist


subroutine gauss
USE PARACLUSTER
USE CLUSTER

Implicit None
Real :: dlaran
!!Real, Intrinsic :: log
Real :: gset1,gset2,gset3,gset4,r
Real :: g4
Integer :: rip
Integer ::ir(4)
!!Intrinsic :: log

         rip=0
ir(1:4)=irand_seed(1:4)
do
   gset1=2.d0*dlaran(irand_seed)-1.d0
   gset2=2.d0*dlaran(irand_seed)-1.d0
   r=gset1*gset1+gset2*gset2
if (r<1) then
           g1=gset1*sqrt(-2.d0*log(r)/r)
           g2=gset2*sqrt(-2.d0*log(r)/r)
           rip=1
else
           rip=0
endif
         if (rip==1) exit
enddo

do
   gset3=2.d0*dlaran(irand_seed)-1.d0
   gset4=2.d0*dlaran(irand_seed)-1.d0
   r=gset3*gset3+gset4*gset4
if (r<1) then
           g3=gset3*sqrt(-2.d0*log(r)/r)
           g4=gset4*sqrt(-2.d0*log(r)/r)
           rip=2
else
          rip=1
endif
         if (rip==2) exit
        enddo
!open(21,file='NUME.out',status='unknown')
!   write(21,'(a5,1x,i5,4f12.5)') 'GAUSS',ipas,g1,g2,g3,g4

End Subroutine GAUSS


! ------------------------------------------------------------------------------
! Copyright (c) 2009-13, Thomas P. Robitaille
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
!  * Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
!  * Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ------------------------------------------------------------------------------

module lib_constants

  implicit none
  save

  integer,parameter,private :: sp = selected_real_kind(p=6,r=37)
  integer,parameter,private :: dp = selected_real_kind(p=15,r=307)

  real(sp),parameter :: zero_sp = 0._sp
  real(dp),parameter :: zero_dp = 0._dp

  real(dp),parameter :: zero = 0._dp
  real(dp),parameter :: half = 0.5_dp
  real(dp),parameter :: one = 1._dp
  real(dp),parameter :: two = 2._dp

  ! Physical constants

  real(dp),parameter :: G_cgs = 6.67300d-08
  real(dp),parameter :: G_si  = 6.67300d-11

  !  N = kg.m/s^2 = [G]*kg^2/m**2
  !  [G] = m^3/s^2/kg

  real(dp),parameter :: k_cgs = 1.380650424d-16 ! erg/K
  real(dp),parameter :: k_si  = 1.380650424d-23 !   J/K

  real(dp),parameter :: h_cgs = 6.6260689633d-27   ! ergs.s
  real(dp),parameter :: h_si  = 6.6260689633e-34_dp !    J.s

  real(dp),parameter :: c_si  = 2.99792458e08_dp ! m / s
  real(dp),parameter :: c_cgs = 2.99792458e10_dp ! cm / s
  ! speed of light

  real(dp),parameter :: kpc_si  = 3.08568025e19_dp ! m
  real(dp),parameter :: kpc_cgs = 3.08568025e21_dp ! cm
  ! kiloparsec

  real(dp),parameter :: pi = 3.14159265358979323846_dp
  real(sp),parameter :: pi_sp = 3.14159265358979323846_sp
  real(dp),parameter :: pi_dp = 3.14159265358979323846_dp

  real(dp),parameter :: twopi = pi + pi
  real(sp),parameter :: twopi_sp = pi_sp + pi_sp
  real(dp),parameter :: twopi_dp = pi_dp + pi_dp

  real(dp),parameter  :: deg2rad = pi / 180._dp
  real(dp),parameter  :: rad2deg = 180._dp / pi
  real(sp),parameter :: deg2rad_sp = pi_sp / 180._sp
  real(sp),parameter :: rad2deg_sp = 180._sp / pi_sp
  real(dp),parameter :: deg2rad_dp = pi_dp / 180._dp
  real(dp),parameter :: rad2deg_dp = 180._dp / pi_dp

  real(dp),parameter :: lsun_cgs = 3.846e33_dp ! erg/s

  real(dp),parameter :: rsun_cgs = 6.95508e10_dp ! cm

  real(dp),parameter :: au_cgs = 1.49598e13_dp ! cm

  real(dp),parameter :: year_cgs = 3600._dp * 24._dp * 365.25_dp

  real(dp),parameter :: msun_cgs = 1.989e33_dp ! g
  ! Conversions

  real(dp),parameter :: ergs2mJy = 1.e26_dp
  real(dp),parameter :: microns2cm = 1.e-4_dp
  real(dp),parameter :: microns2m  = 1.e-6_dp

  real(dp),parameter :: stef_boltz = 5.670400e-5_dp

contains

  real(sp) function infinity_sp()
    implicit none
    real(sp) :: x
    x = huge(1._sp)
    infinity_sp = x + x
  end function infinity_sp

  real(dp) function infinity_dp()
    implicit none
    real(dp) :: x
    x = huge(1._dp)
    infinity_dp = x + x
  end function infinity_dp

end module lib_constants


! Test for the ISNAN intrinsic on constants
!
! { dg-do run }
! { dg-options "-fno-range-check" }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } }
!
  implicit none
  character(len=1) :: s
  write(s,'(L1)') isnan(0.)
  if (s /= 'F') STOP 1

  write(s,'(L1)') isnan(exp(huge(0.)))
  if (s /= 'F') STOP 2

  write(s,'(L1)') isnan(0./0.)
  if (s /= 'T') STOP 3
end


! { dg-do compile { target i?86-*-* x86_64-*-* } }
! { dg-require-effective-target vect_double }
! { dg-require-effective-target sse2 }
! { dg-options "-O3 -ffast-math -msse2 -fpredictive-commoning -ftree-vectorize -fdump-tree-optimized" }

******* RESID COMPUTES THE RESIDUAL:  R = V - AU
*
*      THIS SIMPLE IMPLEMENTATION COSTS  27A + 4M PER RESULT, WHERE
*      A AND M DENOTE THE COSTS OF ADDITION (OR SUBTRACTION) AND
*      MULTIPLICATION, RESPECTIVELY.  BY USING SEVERAL TWO-DIMENSIONAL
*      BUFFERS ONE CAN REDUCE THIS COST TO  13A + 4M IN THE GENERAL
*      CASE, OR  10A + 3M WHEN THE COEFFICIENT A(1) IS ZERO.
*
      SUBROUTINE RESID(U,V,R,N,A)
      INTEGER N
      REAL*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3)
      INTEGER I3, I2, I1
C
      DO 600 I3=2,N-1
      DO 600 I2=2,N-1
      DO 600 I1=2,N-1
 600  R(I1,I2,I3)=V(I1,I2,I3)
     >      -A(0)*( U(I1,  I2,  I3  ) )
     >      -A(1)*( U(I1-1,I2,  I3  ) + U(I1+1,I2,  I3  )
     >                 +  U(I1,  I2-1,I3  ) + U(I1,  I2+1,I3  )
     >                 +  U(I1,  I2,  I3-1) + U(I1,  I2,  I3+1) )
     >      -A(2)*( U(I1-1,I2-1,I3  ) + U(I1+1,I2-1,I3  )
     >                 +  U(I1-1,I2+1,I3  ) + U(I1+1,I2+1,I3  )
     >                 +  U(I1,  I2-1,I3-1) + U(I1,  I2+1,I3-1)
     >                 +  U(I1,  I2-1,I3+1) + U(I1,  I2+1,I3+1)
     >                 +  U(I1-1,I2,  I3-1) + U(I1-1,I2,  I3+1)
     >                 +  U(I1+1,I2,  I3-1) + U(I1+1,I2,  I3+1) )
     >      -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1)
     >                 +  U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1)
     >                 +  U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1)
     >                 +  U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) )
C
      RETURN
      END
! we want to check that predictive commoning did something on the
! vectorized loop, which means we have to have exactly 13 vector
! additions.
! { dg-final { scan-tree-dump-times "vect_var\[^\\n\]*\\+ " 13 "optimized" } }
! { dg-final { cleanup-tree-dump "vect" } }
! { dg-final { cleanup-tree-dump "optimized" } }


FUNCTION wkday(dd,mm,yyyy)
!
IMPLICIT NONE
!
! Function arguments
!
INTEGER :: dd,mm,yyyy
INTEGER :: wkday
!
! Local variables
!
INTEGER :: julday
!
!     + + + purpose + + +
!     given a date in dd/mm/yyyy format
!     wkday will give the day of the week.
!     0 = monday
!     1 = tuesday
!     2 = wednesday
!     3 = thursday
!     4 = friday
!     5 = saturday
!     6 = sunday
!
!     + + + keywords + + +
!     date, utility
!
!     + + + argument declarations + + +
!
!     + + + argument definitions + + +
!     dd     - day
!     mm     - month
!     yyyy   - year
!
!     + + + local definitions + + +
!     julian - julian day value
!
!     + + + function declarations + + +
!
!     + + + end specifications + + +
!
!     we simply find the julian day and do a modulo of the value
!
wkday = mod((julday(dd,mm,yyyy)),7)
!
END FUNCTION wkday

Project Documents/Source Code Original/Wkday.f90


program main

!*****************************************************************************80
!
!! QUAD_MAIN is the main program for the quadrature example.
!
!  Discussion:
!
!    This example estimates an integral using quadrature.
!
!    The integral of F(X) = 4 / ( 1 + X * X ) from 0 to 1 is PI.
!
!    We break up the interval [0,1] into N subintervals, evaluate
!    F(X) at the midpoint of each subinterval, and multiply the
!    sum of these values by N to get an estimate for the integral.
!
!    If we have M processes available because we are using MPI, then
!    we can ask processes 0, 1, 2, ... M-1 to handle the subintervals
!    in the following order:
!
!          0      1       2            M-1  <-- Process numbers begin at 0
!     ------ ------  ------  -----  ------
!          1      2       3    ...       M
!        M+1    M+2     M+3    ...     2*M
!      2*M+1    2*M+2 2*M+3    ...     3*M
!
!    and so on up to subinterval N.  The partial sums collected by
!    each process are then sent to the master process to be added
!    together to get the estimated integral.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 September 2011
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    William Gropp, Ewing Lusk, Anthony Skjellum,
!    Using MPI: Portable Parallel Programming with the
!    Message-Passing Interface,
!    Second Edition,
!    MIT Press, 1999,
!    ISBN: 0262571323.
!
!    Snir, Otto, Huss-Lederman, Walker, Dongarra,
!    MPI - The Complete Reference,
!    Volume 1, The MPI Core,
!    second edition,
!    MIT Press, 1998.
!
  use, intrinsic :: iso_c_binding

  use mpi

  implicit none

  interface
    function quad_compute ( n, comm ) bind ( c )
      use iso_c_binding
      integer ( c_int ), VALUE :: n
      integer ( c_int ) :: comm
      real ( c_double ) :: quad_compute
    end function quad_compute
  end interface

  integer ( c_int ) comm
  real ( kind = 8 ) f
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) id
  integer ( kind = 4 ) ierr
  real ( kind = 8 ) my_part
  integer ( c_int ) n
  integer ( kind = 4 ) n_part
  integer ( kind = 4 ) p
  real ( kind = 8 ) q
  real ( kind = 8 ) q_diff
  real ( kind = 8 ), parameter :: q_exact = 3.141592653589793238462643D+00
  real ( kind = 8 ) q_part
  real ( kind = 8 ) sum2
  real ( kind = 8 ) wtime_diff
  real ( kind = 8 ) wtime_end
  real ( kind = 8 ) wtime_start
  real ( kind = 8 ) x

  call timestamp ( )
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'QUAD_MAIN:'
  write ( *, '(a)' ) '  FORTRAN90/C/MPI version'
  write ( *, '(a)' ) '  An example program to estimate an integral.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  In this example, we have a FORTRAN90 main program,'
  write ( *, '(a)' ) '  and an underlying C function, which must cooperate.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Moreover, the main program invokes the MPI library, and'
  write ( *, '(a)' ) '  the C function must execute within that environment.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  This means that the C function must receive the value'
  write ( *, '(a)' ) '  of MPI_COMM_WORLD from the FORTRAN program.'
!
!  Initialize MPI.
!
  call MPI_Init ( ierr )
!
!  Get this process's ID.
!
  comm = MPI_COMM_WORLD
  call MPI_Comm_rank ( comm, id, ierr )
!
!  Find out how many processes are available.
!
  call MPI_Comm_size ( comm, p, ierr )

  if ( id == 0 ) then
    write ( *, '(a,i8)' ) '  The number of processes is ', p
    wtime_start = MPI_Wtime ( )
  end if

  write ( *, '(a)' ) ' '
  write ( *, '(a,i8,a)' ) 'Process ', id, ' is active.'
!
!  Here we call the C function.
!
  n = 1000
  q_part = quad_compute ( n, comm )
!
!  Each process sends its value of Q_PART to the master process, to
!  be summed in Q.
!
  call MPI_Reduce ( q_part, q, 1, MPI_DOUBLE_PRECISION, MPI_SUM, 0, &
    comm, ierr )

  if ( id == 0 ) then
    wtime_end = MPI_Wtime ( )
  end if
!
!  Finish up.
!
  call MPI_Finalize ( ierr )
!
!  Single process execution.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'QUAD_MAIN:'
  write ( *, '(a,g24.16)' ) '  Integral estimate  ', q
  write ( *, '(a,g24.16)' ) '  Exact value is     ', q_exact
  q_diff = abs ( q_exact - q )
  write ( *, '(a,g24.16)' ) '  Error is           ', q_diff

  wtime_diff = wtime_end - wtime_start

  write ( *, '(a)' ) ' '
  write ( *, '(a,g14.6)' ) '  Elapsed wall clock seconds = ', wtime_diff
!
!  Terminate.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'QUAD_MAIN:'
  write ( *, '(a)' ) '  Normal end of execution.'
  write ( *, '(a)' ) ' '
  call timestamp ( )

  stop
end
subroutine timestamp ( )

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

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

  call date_and_time ( values = values )

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

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

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

  return
end


  FUNCTION InitDist( Model, n, t ) RESULT(f)
    USE Types
    USE SolverUtils
    IMPLICIT NONE

    TYPE(Model_t) :: Model
    LOGICAL :: Visited = .FALSE., GotIt
    INTEGER :: n
    REAL(KIND=dp) :: t,x,y,a1,a2,f

    SAVE Visited, a1, a2

    IF(.NOT. Visited) THEN
      a1 = 5.0_dp
      a2 = 10.0_dp
      Visited = .TRUE.
    END IF

    f = 0.0_dp

    x = Model % Nodes % x(n)
    y = Model % Nodes % y(n)

    ! cut-off Gaussian
    ! f = MIN(1.0_dp, a1*EXP(-a2*(x**2+y**2)))

    ! sharp cylinder
    IF( (x-0.5)**2 + y**2 < 0.3**2 ) f = 1.0_dp

    ! sharp square
    ! IF( ABS(x-0.5) < 0.3 .AND. ABS(y) < 0.3 ) f = 1.0_dp

  END FUNCTION InitDist


*     TB01WD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDU
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDU = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX)
*     .. External Subroutines ..
      EXTERNAL         TB01WD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed ssr for (A,B,C).
               CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU,
     $                      WR, WI, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I)
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01WD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01WD = ',I2)
99997 FORMAT (' The eigenvalues of state dynamics matrix A are ')
99996 FORMAT (/' The transformed state dynamics matrix U''*A*U is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT ( ' (',F8.4,', ',F8.4,' )')
99993 FORMAT (/' The transformed input/state matrix U''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*U is ')
99991 FORMAT (/' The similarity transformation matrix U is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
      END


    !-------------------------------------------------------------------------------------------------------------
    !
    ! DISCLAIMER
    ! ==========
    !
    ! All of the programming herein is original unless otherwise specified.  Details of contributions to the
    ! programming are given below.
    !
    !
    ! Revisions:
    ! ==========
    !
    !    Date          Programmer         Description of change
    !    ----          ----------         ---------------------
    !    09/12/2013    M.H.A. Piro        Original code
    !
    !
    ! Purpose:
    ! ========
    !
    ! The purpose of this subroutine is to calculate the direction vector using an updated Broyden matrix.
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in] m             The number of data-points to be optimized.
    !> \param[in] n             The number of unknown parameters.
    !> \param[inout] s          The change of the unknown variable vector.
    !> \param[in] y             The change of the functional vector.
    !> \param[in] f             The functional vector.
    !> \param[inout] dBroyden   The Broyden matrix (rectangular).
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine optimaDirectionVector(m, n, f, dBroyden, x)

    implicit none

    integer                :: i, j, m, n, k, INFO
    integer,dimension(n)   :: IPIV
    real(8)                :: dTempVar, lambda
    real(8),dimension(m)   :: f
    real(8),dimension(n)   :: B, x
    real(8),dimension(m,n) :: dBroyden
    real(8),dimension(n,n) :: A

    ! Request a value of lambda from the user:
    3000 print *, 'Enter a value for lambda (default = 1):'
    read *, lambda

    if (lambda < 0D0) then
        print *, 'Lambda must be positive. '
        print *
        go to 3000
    end if

    ! Initialize variables:
    INFO     = 0
    IPIV     = 0
    A        = 0D0
    B        = 0D0
    dTempVar = 0D0

    ! Compute the (J^T J) matrix:
    do j = 1, n
        do i = j, n
            dTempVar = 0D0
            do k = 1, m
                dTempVar = dTempVar + dBroyden(k,i) * dBroyden(k,j)
            end do

            ! Compute the coefficient for the A matrix:
            A(i,j) = dTempVar

            ! Apply symmetry:
            A(j,i) = dTempVar
        end do
    end do

    ! Compute the right hand side vector:
    do j = 1, n
        do i = 1, m
            B(j) = B(j) + dBroyden(i,j) * f(i)
        end do
        A(j,j) = A(j,j) + lambda
    end do

    ! Call the linear equation solver:
    call DGESV( n, 1, A, n, IPIV, B, n, INFO )

    ! Check if there were any errors with the linear equation solver:
    if (INFO == 0) then
        ! Successful calculation.

        3010 print *, 'Enter a steplength (0 < alpha >= 1):'
        read *, dTempVar
        print *

        ! Check the steplength:
        if ((dTempVar <= 0D0).OR.(dTempVar > 1D0)) then
            print *, 'The steplength must be greater than zero and less than or equal to one.'
            print *
            goto 3010
        end if

        ! Print results to screen:
        print *, 'Index | direction vector | new values:'
        print *
        do j = 1, n
            !print *, j, B(j)
            print *, j, B(j), x(j) + dTempVar * B(j)
        end do
        print *
    else
        ! Unsuccessful exit.  Report an error and stop.
        print *, 'There was a problem in solving the system of linear equations. '
        print *, 'Error code = ', INFO
        print *
        stop
    end if

    return

end subroutine optimaDirectionVector


      SUBROUTINE SVDFIT(X,Y,SIG,NDATA,A,MA,U,V,W,MP,NP,CHISQ,FUNCS)
      PARAMETER(NMAX=1000,MMAX=50,TOL=1.E-5)
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),A(MA),V(NP,NP),
     *    U(MP,NP),W(NP),B(NMAX),AFUNC(MMAX)
      DO 12 I=1,NDATA
        CALL FUNCS(X(I),AFUNC,MA)
        TMP=1./SIG(I)
        DO 11 J=1,MA
          U(I,J)=AFUNC(J)*TMP
11      CONTINUE
        B(I)=Y(I)*TMP
12    CONTINUE
      CALL SVDCMP(U,NDATA,MA,MP,NP,W,V)
      WMAX=0.
      DO 13 J=1,MA
        IF(W(J).GT.WMAX)WMAX=W(J)
13    CONTINUE
      THRESH=TOL*WMAX
      DO 14 J=1,MA
        IF(W(J).LT.THRESH)W(J)=0.
14    CONTINUE
      CALL SVBKSB(U,W,V,NDATA,MA,MP,NP,B,A)
      CHISQ=0.
      DO 16 I=1,NDATA
        CALL FUNCS(X(I),AFUNC,MA)
        SUM=0.
        DO 15 J=1,MA
          SUM=SUM+A(J)*AFUNC(J)
15      CONTINUE
        CHISQ=CHISQ+((Y(I)-SUM)/SIG(I))**2
16    CONTINUE
      RETURN
      END


      DOUBLE PRECISION FUNCTION gsumln(a,b)
C-----------------------------------------------------------------------
C          EVALUATION OF THE FUNCTION LN(GAMMA(A + B))
C          FOR 1 .LE. A .LE. 2  AND  1 .LE. B .LE. 2
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION x
C     ..
C     .. External Functions ..
      DOUBLE PRECISION alnrel,gamln1
      EXTERNAL alnrel,gamln1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dble,dlog
C     ..
C     .. Executable Statements ..
      x = dble(a) + dble(b) - 2.D0
      IF (x.GT.0.25D0) GO TO 10
      gsumln = gamln1(1.0D0+x)
      RETURN

   10 IF (x.GT.1.25D0) GO TO 20
      gsumln = gamln1(x) + alnrel(x)
      RETURN

   20 gsumln = gamln1(x-1.0D0) + dlog(x* (1.0D0+x))
      RETURN

      END


C		DECLARACAO DE  VARIAVEIS
	INTEGER PRODUC(12,2),CLM(12,2),VALORE(2,2),CLA(2)
C		PRODUC - PRODUCAO MENSAL DE CADA MOTOR
C		CLM - CUSTO E LUCRO MENSAIS DOS MOTORES
C		VALORE - CUSTO E LUCRO DE CADA MOTOR
C		CLA - CUSTO E LUCRO ANUAIS DOS MOTORES
	INTEGER I,J,K
	INTEGER UE,US
	UE = 5
	US = 6
	READ(UE,1) ((PRODUC(I,J),J=1,2,1),I=1,12,1),
     *		   ((VALORE(I,J),J=1,2,1),I=1,2,1)
1	FORMAT(I2,2X,I2)
C		CALCULO DO CUSTO E DO LUCRO MENSAIS
	DO 10 I = 1,12,1
		DO 10 J = 1,2,1
			CLM(I,J) = 0
			DO 10 K = 1,2,1
				CLM(I,J) = CLM(I,J) + PRODUC(I,K)*VALORE(K,J)
10	CONTINUE
C		CALLCULO DO CUSTO E DO LUCRO ANUAIS
	DO 20 J = 1,2,1
		CLA(J) = 0
		DO 20 I = 1,12,1
			CLA(J) = CLA(J) + CLM(I,J)
20	CONTINUE
C		ESCRITA DOS RESULTADOS OBTIDOS
	WRITE(US,22)
22	FORMAT(1H1,	'MES CUSTO LUCRO')
	WRITE(US,24) (I,(CLM(I,J),J=1,2,1),I=1,12,1)
24	FORMAT(1H ,2X,I2,3X,I3,2X,I3)
	WRITE(US,26)
26	FORMAT(1H0,'CUSTOS E LUCROS ANUAIS')
	WRITE(US,28) CLA(1),CLA(2)
28	FORMAT(1H ,1X,I4,6X,I3)
	STOP
	END


*DECK D9GMIT
      DOUBLE PRECISION FUNCTION D9GMIT (A, X, ALGAP1, SGNGAM, ALX)
C***BEGIN PROLOGUE  D9GMIT
C***SUBSIDIARY
C***PURPOSE  Compute Tricomi's incomplete Gamma function for small
C            arguments.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (R9GMIT-S, D9GMIT-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X,
C             SPECIAL FUNCTIONS, TRICOMI
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute Tricomi's incomplete gamma function for small X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DLNGAM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  D9GMIT
      DOUBLE PRECISION A, X, ALGAP1, SGNGAM, ALX, AE, AEPS, ALGS, ALG2,
     1  BOT, EPS, FK, S, SGNG2, T, TE, D1MACH, DLNGAM
      LOGICAL FIRST
      SAVE EPS, BOT, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  D9GMIT
      IF (FIRST) THEN
         EPS = 0.5D0*D1MACH(3)
         BOT = LOG (D1MACH(1))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'D9GMIT',
     +   'X SHOULD BE GT 0', 1, 2)
C
      MA = A + 0.5D0
      IF (A.LT.0.D0) MA = A - 0.5D0
      AEPS = A - MA
C
      AE = A
      IF (A.LT.(-0.5D0)) AE = AEPS
C
      T = 1.D0
      TE = AE
      S = T
      DO 20 K=1,200
        FK = K
        TE = -X*TE/FK
        T = TE/(AE+FK)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 30
 20   CONTINUE
      CALL XERMSG ('SLATEC', 'D9GMIT',
     +   'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2)
C
 30   IF (A.GE.(-0.5D0)) ALGS = -ALGAP1 + LOG(S)
      IF (A.GE.(-0.5D0)) GO TO 60
C
      ALGS = -DLNGAM(1.D0+AEPS) + LOG(S)
      S = 1.0D0
      M = -MA - 1
      IF (M.EQ.0) GO TO 50
      T = 1.0D0
      DO 40 K=1,M
        T = X*T/(AEPS-(M+1-K))
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 50
 40   CONTINUE
C
 50   D9GMIT = 0.0D0
      ALGS = -MA*LOG(X) + ALGS
      IF (S.EQ.0.D0 .OR. AEPS.EQ.0.D0) GO TO 60
C
      SGNG2 = SGNGAM * SIGN (1.0D0, S)
      ALG2 = -X - ALGAP1 + LOG(ABS(S))
C
      IF (ALG2.GT.BOT) D9GMIT = SGNG2 * EXP(ALG2)
      IF (ALGS.GT.BOT) D9GMIT = D9GMIT + EXP(ALGS)
      RETURN
C
 60   D9GMIT = EXP (ALGS)
      RETURN
C
      END