 ! Take the number 192 and multiply it by each of 1, 2, and 3:
 !
 ! 192 × 1 = 192
 ! 192 × 2 = 384
 ! 192 × 3 = 576
 !
 ! By concatenating each product we get the 1 to 9 pandigital, 192384576. We
 ! will call 192384576 the concatenated product of 192 and (1,2,3)
 !
 ! The same can be achieved by starting with 9 and multiplying by 1, 2, 3, 4,
 ! and 5, giving the pandigital, 918273645, which is the concatenated product
 ! of 9 and (1,2,3,4,5).
 !
 ! What is the largest 1 to 9 pandigital 9-digit number that can be formed as
 ! the concatenated product of an integer with (1,2, ... , n) where n > 1?
 !
 ! Project Euler: 38
 !
 ! Answer: 932718654

program main

        use euler

implicit none

        integer (int32), parameter :: MAX_PROD = 9876;
        integer (int32), parameter :: MAX_DIGIT_LEN = 9;
        integer (int32), parameter :: FAULT_BIT_POS = 14;
        integer (int32), parameter :: PANDIGIT_BITM = Z'3FE';

        integer (int32) :: i, largest, tmp;

        largest = 0;

        do i = 2, MAX_PROD
                tmp = pandigital_mult(i);
                largest = merge(tmp, largest, (tmp > largest));
        end do

        print *, largest

contains

        ! This function takes an integer and concatenates its consecutive
        ! products with the previous number. We then test whether the largest
        ! number produced is pandigital--returning the produced number if true,
        ! or returning zero if the number is no pandigital.

        pure function pandigital_mult(i)

                integer, intent(in) :: i;
                integer (int32) :: cat, prod, pandigital_mult;

                cat = i; prod = 2;

                do while (ceiling(log10(real(cat))) < MAX_DIGIT_LEN)
                        cat = concat(cat, prod * i);
                        call inc(prod, 1);
                end do

                pandigital_mult = merge(cat, 0, pandigital(cat));

        end function pandigital_mult

        ! This function concatenates a and b forming ab. Rather concisely, we
        ! take the number 'a' and multiply it by 10 to the power of how long
        ! the 'b' integer is.

        pure function concat(a, b)

                integer, intent(in) :: a, b;
                integer :: concat;

                concat = (a * (10 ** ceiling(log10(real(b))))) + b;

        end function concat

        ! This function initialises an integer where the bits are then used to
        ! represent the presence of digits in the number passed as an argument.
        ! For example, if the number has a '2' in it, then the second bit will
        ! be set. If the bit has already been toggled and there is a secondary
        ! appearance, then the fault bit--bit 14--will be set, and execution of
        ! the loop will stop. This is then compared against 0x3FE, which
        ! represents all numbers being set, which is a pandigital number.

        pure function pandigital(arg)

                integer (int32) :: num, set_ints, ld, pos;
                integer, intent(in) :: arg;
                logical :: pandigital;

                set_ints = 0; num = arg;

                do while (num /= 0 .AND. set_ints <= PANDIGIT_BITM)
                        ld = mod(num, 10)
                        pos = merge(FAULT_BIT_POS, ld, BTEST(set_ints, ld))
                        set_ints = IBSET(set_ints, pos);
                        num = num / 10;
                end do

                pandigital = (set_ints == PANDIGIT_BITM);

        end function pandigital

        ! write(*, '(B0)') set_ints; ! This is used to print binary

end program main


subroutine fl1_distance(n1,n2,nc,A, B, D)

    implicit none
    integer, intent(in) :: n1,n2,nc
    double precision, dimension(nc,n1), intent(in) :: A
    double precision, dimension(nc,n2), intent(in) :: B
    double precision, dimension(n1,n2), intent(out) :: D
    integer :: i, j
    real*8 :: t(nc)

!$OMP PARALLEL DO
    do i = 1, n2
        do j = 1, n1
            D(j,i) = sum(abs(a(:,j) - b(:,i)))
        enddo
    enddo
!$OMP END PARALLEL DO

end subroutine fl1_distance

subroutine fl2_distance(n1,n2,nc,A, B, D)

    implicit none
    integer, intent(in) :: n1,n2,nc
    double precision, dimension(nc,n1), intent(in) :: A
    double precision, dimension(nc,n2), intent(in) :: B
    double precision, dimension(n1,n2), intent(out) :: D
    real*8 :: t(nc)
    integer :: i, j

!$OMP PARALLEL DO PRIVATE(t)
    do i = 1, n2
        do j = 1, n1
            t = A(:,j) - B(:,i)
            D(j,i) = sqrt(sum(t*t))
        enddo
    enddo
!$OMP END PARALLEL DO

end subroutine fl2_distance

subroutine fp_distance_double(A, B, D, p)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:,:), intent(in) :: B
    double precision, dimension(:,:), intent(inout) :: D
    double precision, intent(in) :: p

    integer :: na, nb, nv
    integer :: i, j

    double precision, allocatable, dimension(:) :: temp
    double precision :: inv_p

    nv = size(A, dim=1)

    na = size(A, dim=2)
    nb = size(B, dim=2)

    inv_p = 1.0d0 / p

    allocate(temp(nv))

!$OMP PARALLEL DO PRIVATE(temp)
    do i = 1, nb
        do j = 1, na
            temp(:) = abs(A(:,j) - B(:,i))
            D(j,i) = (sum(temp**p))**inv_p
        enddo
    enddo
!$OMP END PARALLEL DO

    deallocate(temp)

end subroutine fp_distance_double

subroutine fp_distance_integer(A, B, D, p)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:,:), intent(in) :: B
    double precision, dimension(:,:), intent(inout) :: D
    integer, intent(in) :: p

    integer :: na, nb, nv
    integer :: i, j

    double precision, allocatable, dimension(:) :: temp
    double precision :: inv_p

    nv = size(A, dim=1)

    na = size(A, dim=2)
    nb = size(B, dim=2)

    inv_p = 1.0d0 / dble(p)

    allocate(temp(nv))

!$OMP PARALLEL DO PRIVATE(temp)
    do i = 1, nb
        do j = 1, na
            temp(:) = abs(A(:,j) - B(:,i))
            D(j,i) = (sum(temp**p))**inv_p
        enddo
    enddo
!$OMP END PARALLEL DO

    deallocate(temp)

end subroutine fp_distance_integer


subroutine GLQGridCoord(latglq, longlq, lmax)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given a maximum spherical harmonic degree lmax, this routine
!	will determine the latitude and longitude coordinates associated with
!	grids that are used in the Gauss-Legendre quadratue spherical harmonic
!	expansion routines. The coordinates are output in DEGREES.
!
!	Calling Parameters
!		IN
!			lmax		Maximum spherical harmonic degree of the expansion.
!		OUT
!			latglq		Array of latitude points used in Gauss-Legendre grids, in degrees.
!			longlq		Array of longitude points used in Gauss-Legendre grids, in degrees.
!			nlat, nlong	Number of latidude and longitude points.
!
!	Dependencies:		NGLQSH, PreGLQ
!
!	Written by Mark Wieczorek, 2004
!	Completely rewritten June 6, 2006.
!
!	Copyright (c) 2005-2006 Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: NGLQSH, PreGLQ

	implicit none
	integer, intent(in)  ::	lmax
	real*8, intent(out)  ::	latglq(lmax+1), longlq(2*lmax+1)

	real*8               ::	pi, upper, lower, zero(lmax+1), w(lmax+1)
	integer              ::	i, nlat, nlong

	pi    = acos(-1.0d0)

	nlat  = NGLQSH(lmax)
	nlong = 2*lmax +1

	upper = 1.0d0
	lower = -1.0d0

	call PreGLQ(lower, upper, nlat, zero, w)	! Determine Gauss Points and Weights.

	do i=1, nlong
		longlq(i) = 360.0d0*(i-1)/nlong
	enddo

	do i=1, nlat
		latglq(i) = asin(zero(i))*180.0d0/pi
	enddo

end subroutine GLQGridCoord


! The Computer Language Benchmarks Game
! http://benchmarksgame.alioth.debian.org/
!
! Contributed by Jason Blevins
! Adapted from Fortran versions by George R. Gonzalez and Simon Geard
!
! ifort -fast -openmp -o mandelbrot mandelbrot.f90
program mandelbrot
  implicit none

  integer, parameter :: dp = selected_real_kind(15, 307)
  integer, parameter :: int8 = selected_int_kind(2)
  integer, parameter :: iter = 50
  real(dp), parameter :: limit2 = 4.0_dp
  character(len=8) :: argv
  integer :: w, h, x, y, i, pos, bit_num
  integer(int8) :: byte
  real(dp) :: inv_w, inv_h, Zi, Zr, Ti, Tr, Cr, Ci
  logical :: inside
  integer(int8), dimension(:,:), allocatable :: buf

  ! read dimension from command line
  call get_command_argument(1, argv)
  read(argv, *) w
  h = w

  ! allocate output buffer
  allocate(buf(ceiling(w/8.0_dp),h))

  ! precalculate constants
  inv_w = 2.0_dp / w
  inv_h = 2.0_dp / h

  ! pbm header
  write(*,'("P4",/,i0," ",i0)') w, h

  !$OMP PARALLEL DO PRIVATE(y, x, bit_num, pos, byte, Zr, Cr, Ci, inside, i)
  do y = 0, h - 1
     bit_num = 8 ! when moving left to right, bits are numbered 7 to 0
     byte = 0_int8
     pos = 0
     do x = 0, w - 1
        bit_num = bit_num - 1

        Zr = 0.0_dp; Zi = 0.0_dp; Tr = 0.0_dp; Ti = 0.0_dp;
        Cr = inv_w * x - 1.5_dp
        Ci = inv_h * y - 1.0_dp
        inside = .true.
        do i = 1, iter
           Zi = 2.0 * Zr * Zi + Ci
           Zr = Tr - Ti + Cr
           Ti = Zi * Zi
           Tr = Zr * Zr
           if (Tr + Ti > limit2) then
              inside = .false.
              exit
           end if
        end do

        ! We're in the set, set this bit to 0
        if (inside) byte = ibset(byte, bit_num)

        if (bit_num == 0 .or. x == w - 1) then
           ! All bits set or end of row, so store full byte
           pos = pos + 1
           buf(pos,y+1) = byte
           byte = 0_int8
           bit_num = 8
        end if
     end do
  end do
  !$OMP END PARALLEL DO

  ! print output
  do y = 1, h
     write(*, '(10000000a1)', advance='no') buf(:,y)
  end do
  deallocate(buf)
end program mandelbrot


subroutine ff_cylinder(q,R,L,ff,M)
    !***************************************************************************
    !Subroutine to calculate the form factor of cylinder
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Radius of cylinder in Angstroms
    !L = Length of cylinder in Angstroms
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, i, j
    double precision :: q(0:M)
    double precision :: ff(0:M)
    double precision :: R, L, alpha, fact
    double precision, parameter :: pi=3.14157
    integer, parameter :: N=1000

    do i = 0,M
        do j=1,N
            alpha=pi*j/N/2.0
            fact=(sin(q(i)*L*cos(alpha)/2)/(q(i)*L*cos(alpha)/2) * bessel_j1(q(i)*R*sin(alpha))/(q(i)*R*sin(alpha)))**2
            ff(i) = ff(i) + fact * sin(alpha)
        enddo
        ff(i) = ff(i)*pi/N
    enddo

end subroutine ff_cylinder

subroutine ff_cylinder_dist(q,R,Rdist,L,Ldist,ff,M,N)
    !***************************************************************************
    !Subroutine to calculate the form factor of cylinder with disctribution of radius and length
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Array of radii of cylinder in Angstroms
    !Rdist = Probablity distribution of radii R
    !L = Array of Length of cylinder in Angstroms
    !Ldist = Probablity distribution of length L
    !N = No. of samples R and L
    !ff = Form factor of cylinder
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, N, i, j
    double precision :: q(0:M)
    double precision :: ff(0:M)
    double precision :: R(0:N), Rdist(0:N), L(0:N), Ldist(0:N), fact1, fact2, tsum
    double precision, parameter :: pi=3.14157
    integer, parameter :: Nangles=1000
    double precision :: alpha(0:Nangles)

    do j=1,Nangles
        alpha(j)=pi*j/Nangles/2.0
    end do

    do i = 0,M
        ff(i)=0.0d0
        do k=0,N
            tsum=0.0d0
            do j=1,Nangles
                fact1=sin(q(i)*L(k)*cos(alpha(j))/2.0d0)/(q(i)*L(k)*cos(alpha(j))/2.0d0)
                fact2=bessel_j1(q(i)*R(k)*sin(alpha(j)))/(q(i)*R(k)*sin(alpha(j)))
                tsum = tsum + fact1**2*fact2**2*sin(alpha(j))
            enddo
            ff(i) = ff(i)+tsum*Rdist(k)*Ldist(k)
        end do
        ff(i) = ff(i)*pi/sum(Rdist)/sum(Ldist)/Nangles
    enddo

end subroutine ff_cylinder_dist

subroutine ff_cylinder_ml(q,rho,R,L,ff,ffamp,M, Nl)
    !***************************************************************************
    !Subroutine to calculate the form factor of Multilayered Cylinder
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !rho= List of complex electron density of different layers including the solvent
    !R = List of Radius and shell thicknesses of multilayered cylinder in Angstroms
    !L = Length of cylinder in Angstroms
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !Nl = No. of multilayers
    !***************************************************************************
    integer :: M, Nl, i, j, K
    double precision :: q(0:M)
    double precision :: ff(0:M)
    double complex :: rho(0:Nl)
    double precision :: R(0:Nl)
    double precision :: L, alpha, rtemp
    double complex :: fact
    double complex :: ffamp(0:M)
    double precision, parameter :: pi=3.14157
    integer, parameter :: N=1000

    do i = 0,M
        do j=1,N
            alpha=pi*j/N/2.0
            fact=dcmplx(0.0,0.0)
            rtemp=0
            do k=0,Nl-1
                rtemp=rtemp+R(k)
                fact=fact+(rho(k+1)-rho(k))*(dsin(q(i)*L*dcos(alpha)/2)/(q(i)*L*dcos(alpha)/2) &
                * bessel_j1(q(i)*rtemp*dsin(alpha))/(q(i)*rtemp*dsin(alpha)))
            enddo
            ff(i) = ff(i) + cdabs(fact)**2 * dsin(alpha)
            ffamp(i) = ffamp(i) + fact * dsin(alpha)
        enddo
        ff(i) = ff(i)*pi/N
        ffamp(i) = ffamp(i)*pi/N
    enddo

end subroutine ff_cylinder_ml

subroutine ff_cylinder_ml_asaxs(q,H,R,rho,eirho,adensity,Nalf,fft,ffs,ffc,ffr,M,Nlayers)
    !***************************************************************************
    !Subroutine to calculate the form factor of multilayered cylinder with disctribution of radii
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !H = Height of the cylinder
    !R = Array of half of the radii of the core and shells of the cylinder
    !rho = Array of energy dependent electron densities  of core and the shells
    !eirho = Array of energy indepdent electron densities of core and the shells
    !adensity = Array of density of the resonant element in the particle
    !Nlayers = Number of shells plus the core
    !Nalf = Number of azimuthal angle to be integrated for isotropic integration
    !fft = Total scattering from the ellipsoid particle
    !ffs = SAXS-term
    !ffc = Cross-term
    !ffr = Resonant term
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !Nlayers = No. of multilayers in the cylinder
    !***************************************************************************
    integer :: M, i, j, k, Nalf, Nlayers
    double precision :: q(0:M-1)
    double precision :: fft(0:M-1), ffs(0:M-1), ffc(0:M-1), ffr(0:M-1)
    double precision :: R(0:Nlayers-1)
    double complex :: rho(0:Nlayers-1)
    double precision :: eirho(0:Nlayers-1), adensity(0:Nlayers-1)
    double precision :: H, fs, fc, fr, tR, alf, dalf, V, fac
    double complex :: ft, tft
    double precision :: tfs, tfr
    dalf=3.14159/float(Nalf)
    do i = 0,M-1
        fft(i)=0.0d0
        ffs(i)=0.0d0
        ffc(i)=0.0d0
        ffr(i)=0.0d0
        do j = 1, Nalf
            alf=float(j)*dalf
            tR=0.0d0
            tft=0.0d0
            tfs=0.0d0
            tfr=0.0d0
            do k = 0, Nlayers-2
                tR=tR+R(k)
                V=3.14159*tR**2*H
                fac=(dsin(q(i)*H*dcos(alf)/2)/(q(i)*H*dcos(alf)/2) &
                * bessel_j1(q(i)*tR*dsin(alf))/(q(i)*tR*dsin(alf)))
                ft=2*V*(rho(k)-rho(k+1))*fac
                fs=2*V*(eirho(k)-eirho(k+1))*fac
                fr=2*V*(adensity(k)-adensity(k+1))*fac
                fc=fs*fr
                tft=tft+ft
                tfs=tfs+fs
                tfr=tfr+fr
            end do
            fft(i)=fft(i)+cdabs(tft)**2*dsin(alf)
            ffs(i)=ffs(i)+tfs**2*dsin(alf)
            ffc(i)=ffc(i)+tfs*tfr*dsin(alf)
            ffr(i)=ffr(i)+tfr**2*dsin(alf)
        end do

        fft(i)=fft(i)*dalf
        ffs(i)=ffs(i)*dalf
        ffc(i)=ffc(i)*dalf
        ffr(i)=ffr(i)*dalf
    end do

end subroutine ff_cylinder_ml_asaxs


! Rice test
!
module module_bits_8

contains

!-------------------------------------------------------------------------------
! result type in type declaration
!-------------------------------------------------------------------------------
  function number_of_bits8(i) result(num)
    implicit none
    integer :: i, itmp, num
    num = 0
    itmp = i
    do while (itmp .gt. 0)
       num = num + 1
       itmp = ishft(itmp, -1)
    end do
  end function number_of_bits8

end module

program test_module_bits_8
use module_bits_8
integer :: error

error = 0
if (4 .ne. number_of_bits8(14)) then
   error = error + 1
endif

if (0 .ne. error) then
  write(*, '(A)') "Test failed"
else
  write(*, '(A)') "Test passed"
endif

end program


      double precision function fnorm (n, a, w)
clll. optimize
c-----------------------------------------------------------------------
c this function computes the norm of a full n by n matrix,
c stored in the array a, that is consistent with the weighted max-norm
c on vectors, with weights stored in the array w..
c   fnorm = max(i=1,...,n) ( w(i) * sum(j=1,...,n) abs(a(i,j))/w(j) )
c-----------------------------------------------------------------------
      integer n,   i, j
      double precision a,   w, an, sum
      dimension a(n,n), w(n)
      an = 0.0d0
      do 20 i = 1,n
        sum = 0.0d0
        do 10 j = 1,n
 10       sum = sum + dabs(a(i,j))/w(j)
        an = dmax1(an,sum*w(i))
 20     continue
      fnorm = an
      return
c----------------------- end of function fnorm -------------------------
      end


*DECK CSVDC
      SUBROUTINE CSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB,
     +   INFO)
C***BEGIN PROLOGUE  CSVDC
C***PURPOSE  Perform the singular value decomposition of a rectangular
C            matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D6
C***TYPE      COMPLEX (SSVDC-S, DSVDC-D, CSVDC-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX,
C             SINGULAR VALUE DECOMPOSITION
C***AUTHOR  Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     CSVDC is a subroutine to reduce a complex NxP matrix X by
C     unitary transformations U and V to diagonal form.  The
C     diagonal elements S(I) are the singular values of X.  The
C     columns of U are the corresponding left singular vectors,
C     and the columns of V the right singular vectors.
C
C     On Entry
C
C         X         COMPLEX(LDX,P), where LDX .GE. N.
C                   X contains the matrix whose singular value
C                   decomposition is to be computed.  X is
C                   destroyed by CSVDC.
C
C         LDX       INTEGER.
C                   LDX is the leading dimension of the array X.
C
C         N         INTEGER.
C                   N is the number of rows of the matrix X.
C
C         P         INTEGER.
C                   P is the number of columns of the matrix X.
C
C         LDU       INTEGER.
C                   LDU is the leading dimension of the array U
C                   (see below).
C
C         LDV       INTEGER.
C                   LDV is the leading dimension of the array V
C                   (see below).
C
C         WORK      COMPLEX(N).
C                   WORK is a scratch array.
C
C         JOB       INTEGER.
C                   JOB controls the computation of the singular
C                   vectors.  It has the decimal expansion AB
C                   with the following meaning
C
C                        A .EQ. 0    Do not compute the left singular
C                                    vectors.
C                        A .EQ. 1    Return the N left singular vectors
C                                    in U.
C                        A .GE. 2    Return the first MIN(N,P)
C                                    left singular vectors in U.
C                        B .EQ. 0    Do not compute the right singular
C                                    vectors.
C                        B .EQ. 1    Return the right singular vectors
C                                    in V.
C
C     On Return
C
C         S         COMPLEX(MM), where MM = MIN(N+1,P).
C                   The first MIN(N,P) entries of S contain the
C                   singular values of X arranged in descending
C                   order of magnitude.
C
C         E         COMPLEX(P).
C                   E ordinarily contains zeros.  However see the
C                   discussion of INFO for exceptions.
C
C         U         COMPLEX(LDU,K), where LDU .GE. N.  If JOBA .EQ. 1
C                                   then K .EQ. N.  If JOBA .GE. 2 then
C                                   K .EQ. MIN(N,P).
C                   U contains the matrix of right singular vectors.
C                   U is not referenced if JOBA .EQ. 0.  If N .LE. P
C                   or if JOBA .GT. 2, then U may be identified with X
C                   in the subroutine call.
C
C         V         COMPLEX(LDV,P), where LDV .GE. P.
C                   V contains the matrix of right singular vectors.
C                   V is not referenced if JOB .EQ. 0.  If P .LE. N,
C                   then V may be identified with X in the
C                   subroutine call.
C
C         INFO      INTEGER.
C                   The singular values (and their corresponding
C                   singular vectors) S(INFO+1),S(INFO+2),...,S(M)
C                   are correct (here M=MIN(N,P)).  Thus if
C                   INFO.EQ. 0, all the singular values and their
C                   vectors are correct.  In any event, the matrix
C                   B = CTRANS(U)*X*V is the bidiagonal matrix
C                   with the elements of S on its diagonal and the
C                   elements of E on its super-diagonal (CTRANS(U)
C                   is the conjugate-transpose of U).  Thus the
C                   singular values of X and B are the same.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CDOTC, CSCAL, CSROT, CSWAP, SCNRM2, SROTG
C***REVISION HISTORY  (YYMMDD)
C   790319  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CSVDC
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      COMPLEX X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
C
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     1        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      COMPLEX CDOTC,T,R
      REAL B,C,CS,EL,EMM1,F,G,SCNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST,
     1     ZTEST
      LOGICAL WANTU,WANTV
      COMPLEX CSIGN,ZDUM,ZDUM1,ZDUM2
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
      CSIGN(ZDUM1,ZDUM2) = ABS(ZDUM1)*(ZDUM2/ABS(ZDUM2))
C***FIRST EXECUTABLE STATEMENT  CSVDC
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 30
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN(N-1,P)
      NRT = MAX(0,MIN(P-2,N))
      LU = MAX(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = CMPLX(SCNRM2(N-L+1,X(L,L),1),0.0E0)
            IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 10
               IF (CABS1(X(L,L)) .NE. 0.0E0) S(L) = CSIGN(S(L),X(L,L))
               CALL CSCAL(N-L+1,1.0E0/S(L),X(L,L),1)
               X(L,L) = (1.0E0,0.0E0) + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -CDOTC(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL CAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = CONJG(X(L,J))
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = CMPLX(SCNRM2(P-L,E(LP1),1),0.0E0)
            IF (CABS1(E(L)) .EQ. 0.0E0) GO TO 80
               IF (CABS1(E(LP1)) .NE. 0.0E0) E(L) = CSIGN(E(L),E(LP1))
               CALL CSCAL(P-L,1.0E0/E(L),E(LP1),1)
               E(LP1) = (1.0E0,0.0E0) + E(LP1)
   80       CONTINUE
            E(L) = -CONJG(E(L))
            IF (LP1 .GT. N .OR. CABS1(E(L)) .EQ. 0.0E0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = (0.0E0,0.0E0)
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL CAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL CAXPY(N-L,CONJG(-E(J)/E(LP1)),WORK(LP1),1,
     1                       X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
      M = MIN(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = (0.0E0,0.0E0)
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = (0.0E0,0.0E0)
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = (0.0E0,0.0E0)
  180       CONTINUE
            U(J,J) = (1.0E0,0.0E0)
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -CDOTC(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL CAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL CSCAL(N-L+1,(-1.0E0,0.0E0),U(L,L),1)
               U(L,L) = (1.0E0,0.0E0) + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = (0.0E0,0.0E0)
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = (0.0E0,0.0E0)
  260          CONTINUE
               U(L,L) = (1.0E0,0.0E0)
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (CABS1(E(L)) .EQ. 0.0E0) GO TO 320
               DO 310 J = LP1, P
                  T = -CDOTC(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL CAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = (0.0E0,0.0E0)
  330       CONTINUE
            V(L,L) = (1.0E0,0.0E0)
  340    CONTINUE
  350 CONTINUE
C
C     TRANSFORM S AND E SO THAT THEY ARE REAL.
C
      DO 380 I = 1, M
         IF (CABS1(S(I)) .EQ. 0.0E0) GO TO 360
            T = CMPLX(ABS(S(I)),0.0E0)
            R = S(I)/T
            S(I) = T
            IF (I .LT. M) E(I) = E(I)/R
            IF (WANTU) CALL CSCAL(N,R,U(1,I),1)
  360    CONTINUE
         IF (I .EQ. M) GO TO 390
         IF (CABS1(E(I)) .EQ. 0.0E0) GO TO 370
            T = CMPLX(ABS(E(I)),0.0E0)
            R = T/E(I)
            E(I) = T
            S(I+1) = S(I+1)*R
            IF (WANTV) CALL CSCAL(P,R,V(1,I+1),1)
  370    CONTINUE
  380 CONTINUE
  390 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  400 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
         IF (M .EQ. 0) GO TO 660
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 410
            INFO = M
            GO TO 660
  410    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 430 LL = 1, M
            L = M - LL
            IF (L .EQ. 0) GO TO 440
            TEST = ABS(S(L)) + ABS(S(L+1))
            ZTEST = TEST + ABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 420
               E(L) = (0.0E0,0.0E0)
               GO TO 440
  420       CONTINUE
  430    CONTINUE
  440    CONTINUE
         IF (L .NE. M - 1) GO TO 450
            KASE = 4
         GO TO 520
  450    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 470 LLS = LP1, MP1
               LS = M - LLS + LP1
               IF (LS .EQ. L) GO TO 480
               TEST = 0.0E0
               IF (LS .NE. M) TEST = TEST + ABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1))
               ZTEST = TEST + ABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 460
                  S(LS) = (0.0E0,0.0E0)
                  GO TO 480
  460          CONTINUE
  470       CONTINUE
  480       CONTINUE
            IF (LS .NE. L) GO TO 490
               KASE = 3
            GO TO 510
  490       CONTINUE
            IF (LS .NE. M) GO TO 500
               KASE = 1
            GO TO 510
  500       CONTINUE
               KASE = 2
               L = LS
  510       CONTINUE
  520    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (530, 560, 580, 610), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  530    CONTINUE
            MM1 = M - 1
            F = REAL(E(M-1))
            E(M-1) = (0.0E0,0.0E0)
            DO 550 KK = L, MM1
               K = MM1 - KK + L
               T1 = REAL(S(K))
               CALL SROTG(T1,F,CS,SN)
               S(K) = CMPLX(T1,0.0E0)
               IF (K .EQ. L) GO TO 540
                  F = -SN*REAL(E(K-1))
                  E(K-1) = CS*E(K-1)
  540          CONTINUE
               IF (WANTV) CALL CSROT(P,V(1,K),1,V(1,M),1,CS,SN)
  550       CONTINUE
         GO TO 650
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  560    CONTINUE
            F = REAL(E(L-1))
            E(L-1) = (0.0E0,0.0E0)
            DO 570 K = L, M
               T1 = REAL(S(K))
               CALL SROTG(T1,F,CS,SN)
               S(K) = CMPLX(T1,0.0E0)
               F = -SN*REAL(E(K))
               E(K) = CS*E(K)
               IF (WANTU) CALL CSROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  570       CONTINUE
         GO TO 650
C
C        PERFORM ONE QR STEP.
C
  580    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = MAX(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),
     1                    ABS(S(L)),ABS(E(L)))
            SM = REAL(S(M))/SCALE
            SMM1 = REAL(S(M-1))/SCALE
            EMM1 = REAL(E(M-1))/SCALE
            SL = REAL(S(L))/SCALE
            EL = REAL(E(L))/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0
            C = (SM*EMM1)**2
            SHIFT = 0.0E0
            IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 590
               SHIFT = SQRT(B**2+C)
               IF (B .LT. 0.0E0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  590       CONTINUE
            F = (SL + SM)*(SL - SM) - SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 600 K = L, MM1
               CALL SROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = CMPLX(F,0.0E0)
               F = CS*REAL(S(K)) + SN*REAL(E(K))
               E(K) = CS*E(K) - SN*S(K)
               G = SN*REAL(S(K+1))
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL CSROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL SROTG(F,G,CS,SN)
               S(K) = CMPLX(F,0.0E0)
               F = CS*REAL(E(K)) + SN*REAL(S(K+1))
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*REAL(E(K+1))
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     1            CALL CSROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  600       CONTINUE
            E(M-1) = CMPLX(F,0.0E0)
            ITER = ITER + 1
         GO TO 650
C
C        CONVERGENCE.
C
  610    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE
C
            IF (REAL(S(L)) .GE. 0.0E0) GO TO 620
               S(L) = -S(L)
               IF (WANTV) CALL CSCAL(P,(-1.0E0,0.0E0),V(1,L),1)
  620       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  630       IF (L .EQ. MM) GO TO 640
               IF (REAL(S(L)) .GE. REAL(S(L+1))) GO TO 640
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     1            CALL CSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     1            CALL CSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 630
  640       CONTINUE
            ITER = 0
            M = M - 1
  650    CONTINUE
      GO TO 400
  660 CONTINUE
      RETURN
      END


! Module that gives the timestep

module mod_timestep
  use mod_constants
  use mod_read_parameters
  implicit none

  private

  public :: timestep_T, timestep_nu

contains

  subroutine timestep_T(state_in, dt_T)
    implicit none

    type(state),       intent(in)  :: state_in
    real(x_precision), intent(out) :: dt_T

    real(x_precision), dimension(n_cell) :: diffQ
    real(x_precision), dimension(n_cell) :: threshold

    threshold = 1.e10_x_precision
    diffQ     = abs(state_in%Qplus - state_in%Qminus)

    dt_T = minval(state_in%Cv * state_in%T / max(diffQ, threshold)) / cst_dt_T

  end subroutine timestep_T

  subroutine timestep_nu(state_in, dt_nu)
    implicit none

    type(state),       intent(in)  :: state_in
    real(x_precision), intent(out) :: dt_nu

    dt_nu = minval(x_state%x**2 / abs(state_in%v)) / cst_dt_nu / 2

  end subroutine timestep_nu

end module mod_timestep


!
MODULE shape_3d_mod
  !
  ! Shape function library - 2d.
  !
  USE IntrinsicTypesModule, RK=>REAL_KIND
  USE units_mod
  !
  IMPLICIT NONE
  !
CONTAINS
!
!     Shape function routines for 4-node, 10-node tetrahedrons and 8-node brick
!
!     4-NODE TETRAHEDRAON
!     --------------------------
!     sf4t_eval_vec: evaluate shape functions for vector valued quantity
!     .            : at array of points
!     T4_shape_hpar: shape functions for 4-node tetrahedron
!     T4_deriv_hpar: shape function derivatives for 4-node brick
!
!     10-NODE TETRAHEDRAON
!     --------------------------
!     sf10t_eval_vec: evaluate shape functions for vector valued quantity
!                   : at array of points
!     T10_shape_hpar: shape functions for 10-node tetrahedron
!     T10_deriv_hpar: shape function derivatives for 10-node tetrahedron
!
!     8-NODE BRICK
!     --------------------------
!     sf8b_eval_vec: evaluate shape functions for vector valued quantity
!     .            : at array of points
!     B8_shape_hpar: shape functions for 8-node brick
!     B8_deriv_hpar: shape function derivatives for 8-node brick
!
!     sfder_hpar   : compute jacobian determinant and global derivatives
!
!
!***********************************************************************
!
      SUBROUTINE sf10t_eval_vec(vec, npt, pnt, val)
!
!     Evaluate sf functions for vector valued quantity at array of points.
!
!---------------------------------------------------------------------72
!
      USE IntrinsicTypesModule, RK=>REAL_KIND
!
      IMPLICIT NONE
!
!     Arguments.
!
!     vec  -- values of vector at nodes
!     pnt  -- array of points in reference element
!     npt  -- number of points
!     val  -- values of vector at points
!
!     NOTE:  need explicit interface to use assumed shape arrays
!     .      as arguments, i.e. pnt(:), val(:); unless this is
!     .      put in a module or an interface, we can still use
!     .      the assumed-size arrays;
!
      INTEGER, INTENT(IN)   :: npt
      REAL(RK), INTENT(IN)  :: vec(10, 3), pnt(*)
      REAL(RK), INTENT(OUT) :: val(*)
!
!     Locals.
!
      INTEGER  :: i, xdof, ydof, zdof
      REAL(RK) :: x1, x2, x3, sf(10), tmpvec(3)
!
!---------------------------------------------------------------------72
!

      xdof = -2
      do i=1, npt
!
        xdof = xdof + 3; ydof = xdof + 1; zdof = ydof + 1
!
        x1 = pnt(xdof); x2 = pnt(ydof); x3 = pnt(zdof)
!
        sf( 1) = 2.0d0*(x1+x2+x3-1.0d0)*(x1+x2+x3-0.5d0)
        sf( 2) = -4.0d0*(x1+x2+x3-1.0d0)*x1
        sf( 3) = 2.0d0*x1*(x1-0.5d0)
        sf( 4) = 4.0d0*x2*x1
        sf( 5) = 2.0d0*x2*(x2-0.5d0)
        sf( 6) = -4.0d0*(x1+x2+x3-1.0d0)*x2
        sf( 7) = -4.0d0*(x1+x2+x3-1.0d0)*x3
        sf( 8) = 4.0d0*x1*x3
        sf( 9) = 4.0d0*x2*x3
        sf(10) = 2.0d0*x3*(x3-0.5d0)

!
        tmpvec = MATMUL(sf, vec)
!
        val(xdof) = tmpvec(1)
        val(ydof) = tmpvec(2)
        val(zdof) = tmpvec(3)
!
      enddo
!
      RETURN
      END SUBROUTINE
!
!**********************************************************************
!
      SUBROUTINE T10_shape_hpar(loc0, loc1, loc2, shape)
!
!----------------------------------------------------------------------
!
!     Shape functions for 10-node tetrahedron.
!
!     looking down 3-axis
!     2
!     |
!     3--1
!
!     top:
!
!
!     10
!     middle:
!
!     9
!     78
!     bottom:
!     5
!     64
!     123
!
!----------------------------------------------------------------------
!
      USE IntrinsicTypesModule, RK=>REAL_KIND
!
      IMPLICIT NONE
!
!     Arguments.
!
!     loc0,loc1,loc2: coordinates of point
!     shape: shape function value at point, distributed over all elements
!
      REAL(RK)  ::  loc0
      REAL(RK)  ::  loc1
      REAL(RK)  ::  loc2
!
      REAL(RK)  ::  shape(0:nnpe)
!
!----------------------------------------------------------------------
!

      shape(0) = 2.0d0*(loc0+loc1+loc2-1.0d0)*(loc0+loc1+loc2-0.5d0)
      shape(1) = -4.0d0*(loc0+loc1+loc2-1.0d0)*loc0
      shape(2) = 2.0d0*loc0*(loc0-0.5d0)
      shape(3) = 4.0d0*loc1*loc0
      shape(4) = 2.0d0*loc1*(loc1-0.5d0)
      shape(5) = -4.0d0*(loc0+loc1+loc2-1.0d0)*loc1
      shape(6) = -4.0d0*(loc0+loc1+loc2-1.0d0)*loc2
      shape(7) = 4.0d0*loc0*loc2
      shape(8) = 4.0d0*loc1*loc2
      shape(9) = 2.0d0*loc2*(loc2-0.5d0)

      RETURN
      END SUBROUTINE
!
!**********************************************************************
!
      SUBROUTINE T10_deriv_hpar(loc0, loc1, loc2, dnda, dndb, dndc)
!
!     Shape function derivatives for 10-node tetrahedron.
!
!----------------------------------------------------------------------
!
!     Parameters and common blocks.
!
!
      IMPLICIT NONE
!
!     Arguments.
!
!     loc0,loc1,loc2: coordinates of point
!     dnda,dndb,dndc: shape function derivatives at point, distributed
!     *             : over all elements
!
      REAL(RK)  ::  loc0
      REAL(RK)  ::  loc1
      REAL(RK)  ::  loc2
!
      REAL(RK)  ::  dnda(0:nnpe)
      REAL(RK)  ::  dndb(0:nnpe)
      REAL(RK)  ::  dndc(0:nnpe)
!
!----------------------------------------------------------------------
!

      dnda(0) = 4.0d0*(loc0+loc1+loc2)-3.0d0
      dnda(1) = -4.0d0*(2.0d0*loc0+loc1+loc2-1.0d0)
      dnda(2) = 4.0d0*loc0-1.0d0
      dnda(3) = 4.0d0*loc1
      dnda(4) = 0.0d0
      dnda(5) = -4.0d0*loc1
      dnda(6) = -4.0d0*loc2
      dnda(7) = 4.0d0*loc2
      dnda(8) = 0.0d0
      dnda(9) = 0.0d0

      dndb(0) = 4.0d0*(loc0+loc1+loc2)-3.0d0
      dndb(1) = -4.0d0*loc0
      dndb(2) = 0.0d0
      dndb(3) = 4.0d0*loc0
      dndb(4) = 4.0d0*loc1-1.0d0
      dndb(5) = -4.0d0*(loc0+2.0d0*loc1+loc2-1.0d0)
      dndb(6) = -4.0d0*loc2
      dndb(7) = 0.0d0
      dndb(8) = 4.0d0*loc2
      dndb(9) = 0.0d0

      dndc(0) = 4.0d0*(loc0+loc1+loc2)-3.0d0
      dndc(1) = -4.0d0*loc0
      dndc(2) = 0.0d0
      dndc(3) = 0.0d0
      dndc(4) = 0.0d0
      dndc(5) = -4.0d0*loc1
      dndc(6) = -4.0d0*(loc0+loc1+2.0d0*loc2-1.0d0)
      dndc(7) = 4.0d0*loc0
      dndc(8) = 4.0d0*loc1
      dndc(9) = 4.0d0*loc2-1.0d0

      RETURN
      END SUBROUTINE
!
!
!***********************************************************************
!
      SUBROUTINE sf4t_eval_vec(vec, npt, pnt, val)
!
!     Evaluate sf functions for vector valued quantity at array of points.
!
!---------------------------------------------------------------------72
!
      USE IntrinsicTypesModule, RK=>REAL_KIND
!
      IMPLICIT NONE
!
!     Arguments.
!
!     vec  -- values of vector at nodes
!     pnt  -- array of points in reference element
!     npt  -- number of points
!     val  -- values of vector at points
!
!     NOTE:  need explicit interface to use assumed shape arrays
!     .      as arguments, i.e. pnt(:), val(:); unless this is
!     .      put in a module or an interface, we can still use
!     .      the assumed-size arrays;
!
      INTEGER, INTENT(IN):: npt
      REAL(RK), INTENT(IN):: vec(3, 4), pnt(*)
      REAL(RK), INTENT(OUT):: val(*)
!
!     Locals.
!
      INTEGER  :: i, xdof, ydof, zdof
      REAL(RK) :: x1, x2, x3, sf(4), tmpvec(3)
!
!---------------------------------------------------------------------72
!

      xdof = -2
      do i=1, npt
!
        xdof = xdof + 3; ydof = xdof + 1; zdof = ydof + 1
!
        x1 = pnt(xdof); x2 = pnt(ydof); x3 = pnt(zdof)
!
        sf(1) = x1
        sf(2) = x2
        sf(3) = x3
        sf(4) = 1 - (x1 + x2 + x3)

!
        tmpvec = MATMUL(vec, sf)
!
        val(xdof) = tmpvec(1)
        val(ydof) = tmpvec(2)
        val(zdof) = tmpvec(3)
!
      enddo
!
      RETURN
      END SUBROUTINE
!
!**********************************************************************
!
      SUBROUTINE T4_shape_hpar(loc0, loc1, loc2, shape)
!
!     Shape functions for 4-node tetrahedron.
!
!     looking down 3-axis
!     2
!     |
!     3--1
!
!     top:
!
!
!     2
!     bottom:
!     3
!     | \
!     4--1
!
!----------------------------------------------------------------------
!
!
      IMPLICIT NONE
!
!     Arguments.
!
!     loc0,loc1,loc2: coordinates of point
!     shape: shape function value at point, distributed over all elements
!
      REAL(RK)  ::  loc0
      REAL(RK)  ::  loc1
      REAL(RK)  ::  loc2
!
      REAL(RK)  ::  shape(0:nnpe)
!
!----------------------------------------------------------------------
!
      shape(0) = loc0
      shape(1) = loc1
      shape(2) = loc2
      shape(3) = 1.0 - (loc0 + loc1 + loc2)

      RETURN
      END SUBROUTINE
!
!**********************************************************************
!
      SUBROUTINE T4_deriv_hpar(loc0, loc1, loc2, dnda, dndb, dndc)
!
!     Shape function derivatives for 4-node tetrahedron.
!
!----------------------------------------------------------------------
!
!     Parameters and common blocks.
!
!
      IMPLICIT NONE
!
!     Arguments.
!
!     loc0,loc1,loc2: coordinates of point
!     dnda,dndb,dndc: shape function derivatives at point, distributed
!     *             : over all elements
!
      REAL(RK)  ::  loc0
      REAL(RK)  ::  loc1
      REAL(RK)  ::  loc2
!
      REAL(RK)  ::  dnda(0:nnpe)
      REAL(RK)  ::  dndb(0:nnpe)
      REAL(RK)  ::  dndc(0:nnpe)
!
!----------------------------------------------------------------------
!
      dnda(0) = 1.0d0
      dnda(1) = 0.0d0
      dnda(2) = 0.0d0
      dnda(3) = -1.0d0

      dndb(0) = 0.0d0
      dndb(1) = 0.0d0
      dndb(2) = 1.0d0
      dndb(3) = -1.0d0

      dndc(0) = 0.0d0
      dndc(1) = 1.0d0
      dndc(2) = 0.0d0
      dndc(3) = -1.0d0

      RETURN
      END SUBROUTINE
!
!***********************************************************************
!
      SUBROUTINE sf8b_eval_vec(vec, npt, pnt, val)
!
!     Evaluate sf functions for vector valued quantity at array of points.
!
!---------------------------------------------------------------------72
!
      USE IntrinsicTypesModule, RK=>REAL_KIND
!
      IMPLICIT NONE
!
!     Arguments.
!
!     vec  -- values of vector at nodes
!     pnt  -- array of points in reference element
!     npt  -- number of points
!     val  -- values of vector at points
!
!     NOTE:  need explicit interface to use assumed shape arrays
!     .      as arguments, i.e. pnt(:), val(:); unless this is
!     .      put in a module or an interface, we can still use
!     .      the assumed-size arrays;
!
      INTEGER, INTENT(IN):: npt
      REAL(RK), INTENT(IN):: vec(3, 8), pnt(*)
      REAL(RK), INTENT(OUT):: val(*)
!
!     Locals.
!
      INTEGER :: i, xdof, ydof, zdof
      REAL(RK) :: x1, x2, x3, sf(8), tmpvec(3)
!
!---------------------------------------------------------------------72
!

      xdof = -2
      do i=1, npt
!
        xdof = xdof + 3; ydof = xdof + 1; zdof = ydof + 1
!
        x1 = pnt(xdof); x2 = pnt(ydof); x3 = pnt(zdof)
!
        sf(1) = -(x3 - 1.0) * (x2 - 1.0) * (x1 - 1.0)
        sf(2) =  (x3 - 1.0) * (x2 - 1.0) * x1
        sf(3) = -(x3 - 1.0) * x2 * x1
        sf(4) =  (x3 - 1.0) * x2 * (x1 - 1.0)
        sf(5) =  x3 * (x2 - 1.0) * (x1 - 1.0)
        sf(6) = -x3 * (x2 - 1.0) * x1
        sf(7) =  x3 * x2 * x1
        sf(8) = -x3 * x2 * (x1 - 1.0)
!
        tmpvec = MATMUL(vec, sf)
!
        val(xdof) = tmpvec(1)
        val(ydof) = tmpvec(2)
        val(zdof)= tmpvec(3)
!
      enddo
!
      RETURN
      END SUBROUTINE
!
!**********************************************************************
!
      SUBROUTINE B8_shape_hpar(loc0, loc1, loc2, shape)
!
!     Shape functions for 8-node brick.
!
!----------------------------------------------------------------------
!
      USE units_mod
!
      IMPLICIT NONE
!
!     Arguments.
!
!     loc0,loc1,loc2: coordinates of point
!     shape: shape function value at point, distributed over all elements
!
      REAL(RK)  ::  loc0
      REAL(RK)  ::  loc1
      REAL(RK)  ::  loc2
!
      REAL(RK)  ::  shape(0:nnpe)
!
!----------------------------------------------------------------------
!
      shape(0) = -(loc2 - 1.0) * (loc1 - 1.0) * (loc0 - 1.0)
      shape(1) =  (loc2 - 1.0) * (loc1 - 1.0) * loc0
      shape(2) = -(loc2 - 1.0) * loc1 * loc0
      shape(3) =  (loc2 - 1.0) * loc1 * (loc0 - 1.0)
      shape(4) =  loc2 * (loc1 - 1.0) * (loc0 - 1.0)
      shape(5) = -loc2 * (loc1 - 1.0) * loc0
      shape(6) =  loc2 * loc1 * loc0
      shape(7) = -loc2 * loc1 * (loc0 - 1.0)

      RETURN
      END SUBROUTINE
!
!**********************************************************************
!
      SUBROUTINE B8_deriv_hpar(loc0, loc1, loc2, dnda, dndb, dndc)
!
!     Shape function derivatives for 8-node brick.
!
!----------------------------------------------------------------------
!
!     Parameters and common blocks.
!
      USE units_mod
!
      IMPLICIT NONE
!
!     Arguments.
!
!     loc0,loc1,loc2: coordinates of point
!     dnda,dndb,dndc: shape function derivatives at point, distributed
!     *             : over all elements
!
      REAL(RK)  ::  loc0
      REAL(RK)  ::  loc1
      REAL(RK)  ::  loc2
!
      REAL(RK)  ::  dnda(0:nnpe)
      REAL(RK)  ::  dndb(0:nnpe)
      REAL(RK)  ::  dndc(0:nnpe)
!
!----------------------------------------------------------------------
!
      dnda(0) = -(loc2 - 1.0) * (loc1 - 1.0)
      dnda(1) =  (loc2 - 1.0) * (loc1 - 1.0)
      dnda(2) = -(loc2 - 1.0) * loc1
      dnda(3) =  (loc2 - 1.0) * loc1
      dnda(4) =  loc2 * (loc1 - 1.0)
      dnda(5) = -loc2 * (loc1 - 1.0)
      dnda(6) =  loc2 * loc1
      dnda(7) = -loc2 * loc1

      dndb(0) = -(loc2 - 1.0) * (loc0 - 1.0)
      dndb(1) =  (loc2 - 1.0) * loc0
      dndb(2) = -(loc2 - 1.0) * loc0
      dndb(3) =  (loc2 - 1.0) * (loc0 - 1.0)
      dndb(4) =  loc2 * (loc0 - 1.0)
      dndb(5) = -loc2 * loc0
      dndb(6) =  loc2 * loc0
      dndb(7) = -loc2 * (loc0 - 1.0)

      dndc(0) = -(loc1 - 1.0) * (loc0 - 1.0)
      dndc(1) =  (loc1 - 1.0) * loc0
      dndc(2) = -loc1 * loc0
      dndc(3) =  loc1 * (loc0 - 1.0)
      dndc(4) =  (loc1 - 1.0) * (loc0 - 1.0)
      dndc(5) = -(loc1 - 1.0) * loc0
      dndc(6) =  loc1 * loc0
      dndc(7) = -loc1 * (loc0 - 1.0)

      RETURN
      END SUBROUTINE
!
!**********************************************************************
!
      SUBROUTINE sfder_hpar(&
  &   loc0, loc1, loc2, coords, dndx, dndy, dndz, det,&
  &   ijac11, ijac12, ijac13, ijac21, ijac22, ijac23,&
  &   ijac31, ijac32, ijac33&
  &   )
!
!     Compute quadrature quantities given a set of local coordinates.
!
!----------------------------------------------------------------------
!
      use units_mod
!
      IMPLICIT NONE
!
!     Arguments.
!
!     loc0,loc1,loc2: coordinates of point (in reference element)
!     coords        : real coordinates of element's nodes
!     det           : determinant of jacobian
!     dndx,dndy,dndz: derivatives of mapped shape functions
!     ijac{i}{j}    : components of inverse jacobian
!
      REAL(RK), INTENT(IN)  ::  loc0
      REAL(RK), INTENT(IN)  ::  loc1
      REAL(RK), INTENT(IN)  ::  loc2

      REAL(RK), INTENT(IN)  ::  coords(0:nelem1, 0:kdim1)

      REAL(RK), INTENT(OUT)  ::  dndx(0:nelem1, 0:nnpe)
      REAL(RK), INTENT(OUT)  ::  dndy(0:nelem1, 0:nnpe)
      REAL(RK), INTENT(OUT)  ::  dndz(0:nelem1, 0:nnpe)

      REAL(RK), INTENT(OUT)  ::  det(0:nelem1)

      REAL(RK), INTENT(OUT)  ::  ijac11(0:nelem1), ijac12(0:nelem1)
      REAL(RK), INTENT(OUT)  ::  ijac13(0:nelem1), ijac21(0:nelem1)
      REAL(RK), INTENT(OUT)  ::  ijac22(0:nelem1), ijac23(0:nelem1)
      REAL(RK), INTENT(OUT)  ::  ijac31(0:nelem1), ijac32(0:nelem1)
      REAL(RK), INTENT(OUT)  ::  ijac33(0:nelem1)
!
!     Locals.
!
      INTEGER i, j, k, i0, i1, i2
!
      REAL(RK)  ::  dnd1
      REAL(RK)  ::  dnd2
      REAL(RK)  ::  dnd3
!
      REAL(RK)  ::  dnda(0:nnpe)
      REAL(RK)  ::  dndb(0:nnpe)
      REAL(RK)  ::  dndc(0:nnpe)

      REAL(RK)  ::  jac11(0:nelem1)
      REAL(RK)  ::  jac12(0:nelem1)
      REAL(RK)  ::  jac13(0:nelem1)
!
      REAL(RK)  ::  jac21(0:nelem1)
      REAL(RK)  ::  jac22(0:nelem1)
      REAL(RK)  ::  jac23(0:nelem1)
!
      REAL(RK)  ::  jac31(0:nelem1)
      REAL(RK)  ::  jac32(0:nelem1)
      REAL(RK)  ::  jac33(0:nelem1)
!
      integer io
!
!----------------------------------------------------------------------
!
!     Evaluate shape function derivatives
!
!     hardwired
!      call B8_deriv_hpar(loc0, loc1, loc2, dnda, dndb, dndc)
!      call T4_deriv_hpar(loc0, loc1, loc2, dnda, dndb, dndc)
      call T10_deriv_hpar(loc0, loc1, loc2, dnda, dndb, dndc)
!
!     Zero the jacobian matrix
!
      jac11 = 0.0
      jac12 = 0.0
      jac13 = 0.0
      jac21 = 0.0
      jac22 = 0.0
      jac23 = 0.0
      jac31 = 0.0
      jac32 = 0.0
      jac33 = 0.0

      do i = 0, nnpe
        i0 = 3 * i
        i1 = i0 + 1
        i2 = i1 + 1

        dnd1 = dnda(i)
        dnd2 = dndb(i)
        dnd3 = dndc(i)

        ijac11(:) = coords(:, i0)
        ijac22(:) = coords(:, i1)
        ijac33(:) = coords(:, i2)

        jac11 = jac11 + ijac11 * dnd1
        jac21 = jac21 + ijac11 * dnd2
        jac31 = jac31 + ijac11 * dnd3
        jac12 = jac12 + ijac22 * dnd1
        jac22 = jac22 + ijac22 * dnd2
        jac32 = jac32 + ijac22 * dnd3
        jac13 = jac13 + ijac33 * dnd1
        jac23 = jac23 + ijac33 * dnd2
        jac33 = jac33 + ijac33 * dnd3
      end do
!
!     Determinant of the jacobian matrix
!
      ijac11 = jac11 * jac22 * jac33
      ijac12 = jac12 * jac23 * jac31
      ijac13 = jac13 * jac21 * jac32
      ijac21 = jac11 * jac23 * jac32
      ijac22 = jac12 * jac21 * jac33
      ijac23 = jac13 * jac22 * jac31

      det = ijac11 + ijac12 + ijac13
      det = det - (ijac21 + ijac22 + ijac23)
!
!     Inverse of the jacobian matrix
!
      ijac11 = jac22 * jac33 - jac23 * jac32
      ijac21 = jac23 * jac31 - jac21 * jac33
      ijac31 = jac21 * jac32 - jac22 * jac31
      ijac12 = jac13 * jac32 - jac12 * jac33
      ijac22 = jac11 * jac33 - jac13 * jac31
      ijac32 = jac31 * jac12 - jac11 * jac32
      ijac13 = jac12 * jac23 - jac13 * jac22
      ijac23 = jac13 * jac21 - jac11 * jac23
      ijac33 = jac11 * jac22 - jac12 * jac21

      ijac11 = ijac11 / det
      ijac12 = ijac12 / det
      ijac13 = ijac13 / det
      ijac21 = ijac21 / det
      ijac22 = ijac22 / det
      ijac23 = ijac23 / det
      ijac31 = ijac31 / det
      ijac32 = ijac32 / det
      ijac33 = ijac33 / det
!
!     Finally the shape function derivatives
!
      do i = 0, nnpe
        dnd1 = dnda(i)
        dnd2 = dndb(i)
        dnd3 = dndc(i)

        jac11 = ijac11 * dnd1 + ijac12 * dnd2 + ijac13 * dnd3
        jac22 = ijac21 * dnd1 + ijac22 * dnd2 + ijac23 * dnd3
        jac33 = ijac31 * dnd1 + ijac32 * dnd2 + ijac33 * dnd3

        dndx(:, i) = jac11
        dndy(:, i) = jac22
        dndz(:, i) = jac33
      end do

      RETURN
      END SUBROUTINE
!
!
END MODULE shape_3d_mod


module other_routines
implicit none
contains

!----------------------------
! Functions to optimize:
!----------------------------

! function 1:
real(kind=8) function f1 (var)
   real(kind=8), allocatable, dimension (:), intent(in) :: var
   real(kind=8) :: x, y
   x = var(1)
   y = var(2)
   f1 = ( sin(x)**2 + cos(x)**2 ) / ( 5.0d0 + x**2 + y**2 )
end function f1

! number of variables in function 1:
integer function f1_nvar ()
   f1_nvar = 2
end function f1_nvar

! function 2:
real(kind=8) function f2 (var)
   real(kind=8), allocatable, dimension (:), intent(in) :: var
   real(kind=8) :: x, y
   x = var(1)
   y = var(2)
   f2 =-(y + 47.0d0)*sin(sqrt(abs(y + x/2.0d0 + 47.0d0))) - x*sin(sqrt(abs(x - (y + 47.0d0))))
end function f2

! number of variables in function 2:
integer function f2_nvar ()
   f2_nvar = 2
end function f2_nvar

!-----------------------------------
! Random number distributions:
!-----------------------------------

subroutine bernoulli_distribution (del_k)
   real(kind=8), allocatable, dimension(:), intent(inout) :: del_k
   integer :: i, n

   n = size(del_k)
   do i = 1, n
      call random_number(del_k(i))
      if (del_k(i) .gt. 0.5) then
         del_k(i) = 1.0d0
      else if (del_k(i) .le. 0.5) then
         del_k(i) = -1.0d0
      end if
   end do
end subroutine bernoulli_distribution

subroutine split_uniform (del_k)
   real(kind=8), allocatable, dimension(:), intent(inout) :: del_k
   integer :: i, n

   ! mean magnitude = 0.95
   ! variance = 1
   ! del_k(i) e [-1.4908,-0.4092] ^ [0.4092,1.4908]

   n = size(del_k)
   i = 1
   do while (i .le. n)
      call random_number(del_k(i))
      del_k(i) = (del_k(i)*2.0d0*1.4908d0) - 1.4908d0
      if (dabs(del_k(i)) .ge. 0.4092d0) then
         i = i + 1
      end if
   end do
end subroutine split_uniform

end module other_routines


! { dg-do run }

! Type-bound procedures
! Check basic calls to NOPASS type-bound procedures.

MODULE m
  IMPLICIT NONE

  TYPE add
  CONTAINS
    PROCEDURE, NOPASS :: func => func_add
    PROCEDURE, NOPASS :: sub => sub_add
    PROCEDURE, NOPASS :: echo => echo_add
  END TYPE add

  TYPE mul
  CONTAINS
    PROCEDURE, NOPASS :: func => func_mul
    PROCEDURE, NOPASS :: sub => sub_mul
    PROCEDURE, NOPASS :: echo => echo_mul
  END TYPE mul

CONTAINS

  INTEGER FUNCTION func_add (a, b)
    IMPLICIT NONE
    INTEGER :: a, b
    func_add = a + b
  END FUNCTION func_add

  INTEGER FUNCTION func_mul (a, b)
    IMPLICIT NONE
    INTEGER :: a, b
    func_mul = a * b
  END FUNCTION func_mul

  SUBROUTINE sub_add (a, b, c)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: a, b
    INTEGER, INTENT(OUT) :: c
    c = a + b
  END SUBROUTINE sub_add

  SUBROUTINE sub_mul (a, b, c)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: a, b
    INTEGER, INTENT(OUT) :: c
    c = a * b
  END SUBROUTINE sub_mul

  SUBROUTINE echo_add ()
    IMPLICIT NONE
    WRITE (*,*) "Hi from adder!"
  END SUBROUTINE echo_add

  INTEGER FUNCTION echo_mul ()
    IMPLICIT NONE
    echo_mul = 5
    WRITE (*,*) "Hi from muler!"
  END FUNCTION echo_mul

  ! Do the testing here, in the same module as the type is.
  SUBROUTINE test ()
    IMPLICIT NONE

    TYPE(add) :: adder
    TYPE(mul) :: muler

    INTEGER :: x

    IF (adder%func (2, 3) /= 5 .OR. muler%func (2, 3) /= 6) THEN
      CALL abort ()
    END IF

    CALL adder%sub (2, 3, x)
    IF (x /= 5) THEN
      CALL abort ()
    END IF

    CALL muler%sub (2, 3, x)
    IF (x /= 6) THEN
      CALL abort ()
    END IF

    ! Check procedures without arguments.
    CALL adder%echo ()
    x = muler%echo ()
    CALL adder%echo
  END SUBROUTINE test

END MODULE m

PROGRAM main
  USE m, ONLY: test
  CALL test ()
END PROGRAM main


! Subroutine for determine matrix transpose AT=A^T
!
! Igor Lopes, February 2015
SUBROUTINE TRANSPOSE(A,AT,NROWA,NCOLA)
    IMPLICIT NONE
    ! Arguments
    INTEGER :: NROWA , NCOLA
    REAL(8), DIMENSION(NROWA,NCOLA)  :: A
    REAL(8), DIMENSION(NCOLA, NROWA) :: AT
    ! Locals
    INTEGER I, J
    ! Begin algorithm
    DO J=1,NCOLA
	    DO I=1,NROWA
		    AT(J,I)=A(I,J)
	    ENDDO
    ENDDO
END SUBROUTINE


    MODULE random_f_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

!*********************************************************************

      FUNCTION random_f(dfn,dfd)
! .. Use Statements ..
        USE random_standard_gamma_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_f
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: dfd, dfn
! ..
! .. Local Scalars ..
        REAL :: xden, xnum
! ..
! .. Executable Statements ..

!**********************************************************************
!     REAL FUNCTION RANDOM_F( DFN, DFD )
!                GENerate random deviate from the F distribution
!                              Function
!     Generates a random deviate from the F (variance ratio)
!     distribution with DFN degrees of freedom in the numerator
!     and DFD degrees of freedom in the denominator.
!                              Arguments
!     DFN --> Numerator degrees of freedom
!             (Must be positive)
!                              REAL DFN
!      DFD --> Denominator degrees of freedom
!             (Must be positive)
!                              REAL DFD
!                              Method
!     Directly generates ratio of chisquare variates
!**********************************************************************
!     JJV changed this code to call random_standard_gamma directly
!      REAL random_chisq
!      EXTERNAL random_chisq
        IF (dfn<=0.0 .OR. dfd<=0.0) THEN
          WRITE (*,*) 'Degrees of freedom nonpositive in GENF - abort!'
          WRITE (*,*) 'DFN value: ', dfn, 'DFD value: ', dfd
          STOP 'Degrees of freedom nonpositive in GENF - abort!'
        END IF

        xnum = 2.0*random_standard_gamma(dfn/2.0)/dfn

!      GENF = ( GENCHI( DFN ) / DFN ) / ( GENCHI( DFD ) / DFD )
        xden = 2.0*random_standard_gamma(dfd/2.0)/dfd
!     JJV changed constant so that it will not underflow at compile time
!     JJV while not slowing generator by using double precision or logs.
!      IF (.NOT. (xden.LE. (1.0E-38*xnum))) GO TO 20
        IF (xden<=1.0E-37*xnum) THEN
          WRITE (*,*) ' GENF - generated numbers would cause overflow'
          WRITE (*,*) ' Numerator ', xnum, ' Denominator ', xden
!     JJV next 2 lines changed to maintain truncation of large deviates.
!      WRITE (*,*) ' GENF returning 1.0E38'
!      random_f = 1.0E38
          WRITE (*,*) ' GENF returning 1.0E37'
          random_f = 1.0E37
        ELSE

          random_f = xnum/xden
        END IF
        RETURN

      END FUNCTION random_f

!*********************************************************************

    END MODULE random_f_mod


program main
  ! Default
  implicit none

  ! Variables
  integer(4) :: i,sum

  ! Do work
  sum = 0
  do i=1,999
     if (mod(i,3)==0 .or. mod(i,5)==0) then
        sum = sum + i
     endif
  enddo

  ! Write out result
  write(*,*) 'Sum: ',sum
end program main


PROGRAM KNAPSACK

  IMPLICIT NONE

  REAL :: totalWeight, totalVolume
  INTEGER :: maxPanacea, maxIchor, maxGold, maxValue = 0
  INTEGER :: i, j, k
  INTEGER :: n(3)

  TYPE Bounty
    INTEGER :: value
    REAL :: weight
    REAL :: volume
  END TYPE Bounty

  TYPE(Bounty) :: panacea, ichor, gold, sack, current

  panacea = Bounty(3000, 0.3, 0.025)
  ichor   = Bounty(1800, 0.2, 0.015)
  gold    = Bounty(2500, 2.0, 0.002)
  sack    = Bounty(0, 25.0, 0.25)

  maxPanacea = MIN(sack%weight / panacea%weight, sack%volume / panacea%volume)
  maxIchor = MIN(sack%weight / ichor%weight, sack%volume / ichor%volume)
  maxGold = MIN(sack%weight / gold%weight, sack%volume / gold%volume)

  DO i = 0, maxPanacea
     DO j = 0, maxIchor
        Do k = 0, maxGold
           current%value = k * gold%value + j * ichor%value + i * panacea%value
           current%weight = k * gold%weight + j * ichor%weight + i * panacea%weight
           current%volume = k * gold%volume + j * ichor%volume + i * panacea%volume
           IF (current%weight > sack%weight .OR. current%volume > sack%volume) CYCLE
           IF (current%value > maxValue) THEN
              maxValue = current%value
              totalWeight = current%weight
              totalVolume = current%volume
              n(1) = i ; n(2) = j ; n(3) = k
           END IF
        END DO
     END DO
  END DO

  WRITE(*, "(A,I0)") "Maximum value achievable is ", maxValue
  WRITE(*, "(3(A,I0),A)") "This is achieved by carrying ", n(1), " panacea, ", n(2), " ichor and ", n(3), " gold items"
  WRITE(*, "(A,F4.1,A,F5.3)") "The weight to carry is ", totalWeight, " and the volume used is ", totalVolume

END PROGRAM KNAPSACK


C++*************************************************
C Program POLAR to compute the polar coordinates (angle and separation)
C from the Cartesian coordinates of two points
C--*************************************************
        PROGRAM POLAR
        REAL*4 X1,Y1,X2,Y2,RAD,ANGLE,ANGLE2,A,B,PI
        PI=ACOS(-1.)

        WRITE(6,20)
20      FORMAT('Program POLAR to compute the polar coordinates',
     1         ' (angle and separation)',/,
     1         'from the Cartesian coordinates of two points')
        WRITE(6,21)
21      FORMAT(' Enter the X, Y coordinates of the first point (origin):')
        READ(5,*) X1,Y1
        WRITE(6,22)
22      FORMAT(' Enter the X, Y coordinates of the second point:')
        READ(5,*) X2,Y2
        A=X2-X1
        B=Y2-Y1
        RAD=SQRT(A*A+B*B)

        IF(RAD.LT.1.E-9) THEN
         WRITE(6,100)
100      FORMAT(' Radius is too small')
         ANGLE=0.0
        ENDIF

        IF(B.GT.0.)THEN
          ANGLE=ACOS(A/RAD)*180./PI
        ELSEIF(B.LT.0)THEN
          ANGLE=ACOS(-A/RAD)*180./PI+180.
        ELSEIF(B.EQ.0)THEN
          IF(A.GT.0)ANGLE=0.0D0
          IF(A.LT.0)ANGLE=180.
        ENDIF

        IF(ANGLE.LT.0.)ANGLE = ANGLE+360.
        WRITE(6,30) X1,Y1,X2,Y2,RAD,ANGLE
30      FORMAT(' X1,Y1= ',2(G12.5,1X),3X,' X2,Y2= ',2(G12.5,1X),/,
     1         ' Radius: ',G12.5,'   Angle: ',G12.5,' (degrees)')

C ANGLE is between 0 and 360 degrees,
C ANGLE2 is between -90 and 90 degrees modulus 180 degrees (for speckle)
        ANGLE2=ANGLE
        IF(ANGLE2.GT.180.)ANGLE2 = ANGLE2 - 180.
        IF(ANGLE2.GT.90.)ANGLE2 = ANGLE2 - 180.
        WRITE(6,32) ANGLE2
32      FORMAT(' For speckle: angle2=',G12.5)
        STOP
        END


	PROGRAM Kg
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Klein-Gordon equation in 3 dimensions
	! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*|u|^2u
	! using a second order implicit-explicit time stepping scheme.
	!
	! The boundary conditions are u(x=-Lx*pi,y,z)=u(x=Lx*\pi,y,z),
	!	u(x,y=-Ly*pi,z)=u(x,y=Ly*pi,z),u(x,y,z=-Ly*pi)=u(x,y,z=Ly*pi),
	! The initial condition is u=0.5*exp(-x^2-y^2-z^2)*sin(10*x+12*y)
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD     = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	!  ES				= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfxy			= Forward 2d fft plan
	!  planbxy			= Backward 2d fft plan
	!  dt				= timestep
	!  modescalereal	= Number to scale after backward FFT
	!  ierr				= error code
	!  plotnum			= number of plot
	! .. Arrays ..
	!  unew 			= approximate solution
	!  vnew 			= Fourier transform of approximate solution
	!  u 				= approximate solution
	!  v 				= Fourier transform of approximate solution
	!  uold 			= approximate solution
	!  vold 			= Fourier transform of approximate solution
	!  nonlin 			= nonlinear term, u^3
	!  nonlinhat 		= Fourier transform of nonlinear term, u^3
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  kz				= fourier frequencies in z direction
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!  time				= times at which save data
	!  en				= total energy
	!  enstr			= strain energy
	!  enpot			= potential energy
	!  enkin			= kinetic energy
	!  name_config		= array to store filename for data to be saved
	!  fftfxyz			= array to setup 2D Fourier transform
	!  fftbxyz			= array to setup 2D Fourier transform
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!	getgrid.f90	-- Get initial grid of points
	! 	initialdata.f90 -- Get initial data
	!	enercalc.f90 -- Subroutine to calculate the energy
	!	savedata.f90 -- Save initial data
	!	storeold.f90 -- Store old data
	! External libraries required
	! 	FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! 	OpenMP library
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(kind=4), PARAMETER	:: Nx=512
	INTEGER(kind=4), PARAMETER 	:: Ny=512
	INTEGER(kind=4), PARAMETER 	:: Nz=512
	INTEGER(kind=4), PARAMETER	:: Nt=10
	INTEGER(kind=4), PARAMETER	:: plotgap=5
	REAL(kind=8), PARAMETER		:: &
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER		::  Lx=64.0d0
	REAL(kind=8), PARAMETER		::  Ly=64.0d0
	REAL(kind=8), PARAMETER		::  Lz=64.0d0
	REAL(kind=8), PARAMETER		::  Es=1.0d0
	REAL(kind=8)				::  dt=0.00025
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	::  kx,ky,kz
	REAL(kind=8),  	 DIMENSION(:), ALLOCATABLE	::  x,y,z
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  u,nonlin
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  v,nonlinhat
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  uold
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  vold
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  unew
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  vnew
	REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE :: savearray
	REAL(kind=8), DIMENSION(:), ALLOCATABLE	::  time,enkin,enstr,enpot,en
	REAL(kind=8) :: modescalereal
	INTEGER(kind=4)	::  ierr,i,j,k,n,allocatestatus,numthreads
	INTEGER(kind=4)	::  start, finish, count_rate, plotnum
	INTEGER(kind=4), PARAMETER	::  FFTW_IN_PLACE = 8, FFTW_MEASURE = 0, &
		FFTW_EXHAUSTIVE = 8, FFTW_PATIENT = 32, FFTW_ESTIMATE = 64
	INTEGER(kind=4),PARAMETER	::  FFTW_FORWARD = -1, FFTW_BACKWARD=1
	INTEGER(kind=8)	::  planfxyz,planbxyz
	CHARACTER*100	::  name_config

	numthreads=omp_get_max_threads()
    PRINT *,'There are ',numthreads,' threads.'
	ALLOCATE(kx(1:Nx),ky(1:Ny),kz(1:Nz),x(1:Nx),y(1:Ny),z(1:Nz),u(1:Nx,1:Ny,1:Nz),&
			v(1:Nx,1:Ny,1:Nz),nonlin(1:Nx,1:Ny,1:Nz),nonlinhat(1:Nx,1:Ny,1:Nz),&
			uold(1:Nx,1:Ny,1:Nz),vold(1:Nx,1:Ny,1:Nz),&
			unew(1:Nx,1:Ny,1:Nz),vnew(1:Nx,1:Ny,1:Nz),savearray(1:Nx,1:Ny,1:Nz),&
			time(1:1+Nt/plotgap),enkin(1:1+Nt/plotgap),enstr(1:1+Nt/plotgap),&
			enpot(1:1+Nt/plotgap),en(1:1+Nt/plotgap),stat=allocatestatus)
	IF (allocatestatus .ne. 0) stop
	PRINT *,'allocated arrays'

	! set up multithreaded ffts
	CALL dfftw_init_threads_(ierr)
	PRINT *,'Initiated threaded FFTW'
	CALL dfftw_plan_with_nthreads_(numthreads)
	PRINT *,'Inidicated number of threads to be used in planning'
	CALL dfftw_plan_dft_3d_(planfxyz,Nx,Ny,Nz,u,v,&
							FFTW_FORWARD,FFTW_ESTIMATE)
 	CALL dfftw_plan_dft_3d_(planbxyz,Nx,Ny,Nz,v,u,&
 							FFTW_BACKWARD,FFTW_ESTIMATE)
	PRINT *,'Setup FFTs'
	! setup fourier frequencies
	CALL getgrid(Nx,Ny,Nz,Lx,Ly,Lz,pi,name_config,x,y,z,&
				kx,ky,kz)
	PRINT *,'Setup grid and fourier frequencies'
	CALL initialdata(Nx,Ny,Nz,x,y,z,u,uold)
	plotnum=1
	name_config = 'data/u'
	savearray=REAL(u)
	CALL savedata(Nx,Ny,Nz,plotnum,name_config,savearray)

	CALL dfftw_execute_dft_(planfxyz,u,v)
	CALL dfftw_execute_dft_(planfxyz,uold,vold)

	modescalereal=1.0d0/REAL(Nx,KIND(0d0))
	modescalereal=modescalereal/REAL(Ny,KIND(0d0))
	modescalereal=modescalereal/REAL(Nz,KIND(0d0))

	CALL enercalc(Nx,Ny,Nz,planfxyz,planbxyz,dt,Es,modescalereal,&
				enkin(plotnum),enstr(plotnum),&
				enpot(plotnum),en(plotnum),&
				kx,ky,kz,nonlin,nonlinhat,&
				v,vold,u,uold)

	PRINT *,'Got initial data, starting timestepping'
	time(plotnum)=0.0d0
  	CALL system_clock(start,count_rate)
	DO n=1,Nt
		!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
		DO k=1,Nz
			DO j=1,Ny
				DO i=1,Nx
					nonlin(i,j,k)=(abs(u(i,j,k))*2)*u(i,j,k)
				END DO
			END DO
		END DO
		!$OMP END PARALLEL DO
		CALL dfftw_execute_dft_(planfxyz,nonlin,nonlinhat)
		!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
		DO k=1,Nz
			DO j=1,Ny
				DO i=1,Nx
					vnew(i,j,k)=&
					( 0.25*(kx(i)*kx(i) + ky(j)*ky(j)+ kz(k)*kz(k)-1.0d0)&
					*(2.0d0*v(i,j,k)+vold(i,j,k))&
					+(2.0d0*v(i,j,k)-vold(i,j,k))/(dt*dt)&
					+Es*nonlinhat(i,j,k) )&
					/(1/(dt*dt)-0.25*(kx(i)*kx(i)+ ky(j)*ky(j)+ kz(k)*kz(k)-1.0d0))
				END DO
			END DO
		END DO
		!$OMP END PARALLEL DO
		CALL dfftw_execute_dft_(planbxyz,vnew,unew)
		! normalize result
		!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
		DO k=1,Nz
			DO j=1,Ny
				DO i=1,Nx
					unew(i,j,k)=unew(i,j,k)*modescalereal
				END DO
			END DO
		END DO
		!$OMP END PARALLEL DO
		IF (mod(n,plotgap)==0) then
			plotnum=plotnum+1
			time(plotnum)=n*dt
			PRINT *,'time',n*dt
			CALL enercalc(Nx,Ny,Nz,planfxyz,planbxyz,dt,Es,modescalereal,&
				enkin(plotnum),enstr(plotnum),&
				enpot(plotnum),en(plotnum),&
				kx,ky,kz,nonlin,nonlinhat,&
				vnew,v,unew,u)
			savearray=REAL(unew,kind(0d0))
			CALL savedata(Nx,Ny,Nz,plotnum,name_config,savearray)
		END IF
			! .. Update old values ..
		CALL storeold(Nx,Ny,Nz,unew,u,uold,vnew,v,vold)
	END DO
	PRINT *,'Finished time stepping'
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',&
		REAL(finish-start,kind(0d0))/REAL(count_rate,kind(0d0)),&
		'for Time stepping'
	CALL saveresults(Nt,plotgap,time(1:1+n/plotgap),en(1:1+n/plotgap),&
			enstr(1:1+n/plotgap),enkin(1:1+n/plotgap),enpot(1:1+n/plotgap))

	! Save times at which output was made in text format
	PRINT *,'Saved data'

	CALL dfftw_destroy_plan_(planbxyz)
	CALL dfftw_destroy_plan_(planfxyz)
	CALL dfftw_cleanup_threads_()
	DEALLOCATE(kx,ky,kz,x,y,z,u,v,nonlin,nonlinhat,savearray,&
		uold,vold,unew,vnew,time,enkin,enstr,enpot,en,&
		stat=allocatestatus)
	IF (allocatestatus .ne. 0) STOP
	PRINT *,'Deallocated arrays'
	PRINT *,'Program execution complete'
	END PROGRAM Kg