MODULE Gauss_Weights

!      ALGORITHM 125, COLLECTED ALGORITHMS FROM ACM.
!      THIS WORK PUBLISHED IN COMMUNICATIONS OF THE ACM,
!      VOL. 5, NO. 10, October, 1962, P.  510--511

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-03  Time: 14:03:32

! Original Fortran translation donated by

! M.Dow@anu.edu.au
! ANUSF,  Australian National University
! Canberra, Australia

! Tidied up to use workspace arrays, dimension arrays to
! required lengths, use 0: for dimensions of A, add comments,
! and NAG tools to layout source

! trh (20/07/97)

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)

CONTAINS

SUBROUTINE weightc(n, q, e, eps, w, x)

! Computes the abscissae x(i) and the weight coefficients w(i) for a
! Gaussian quadrature method
!      \int_0^b w(x)f(x) dx \approx \sum_{i=1}^{n}w_if(x_i) where
! \int_0^b w(x) dx = 1 and w(x)>= 0. The method requires the order n, a
! tolerance eps and the 2n-1 first coefficients of the continued fraction
!      \int_0^b {w(x) \over z-x} = { 1| \over |z} - {q_1 | \over |1} -
!      {e_1 | \over |z} - {q_2 | \over |1} -
!      {e_2 | \over |z} - \cdots
! to be given, the latter in the two arrays q(n) and e(n-1) all components
! of which are automatically positive by virtue of the condition w(x)>= 0.
! The method works as well if the upper bound b is actually infinity
! (note that b does not appear directly as an argument!) or if the density
! function w(x) dx is replaced by da(x) with a monotonically increasing a(x)
! with at least n points of of variation. The tolerance eps should be given
! in accordance to the machines accuracy (preferably by using the value of
! d1mach(4)).  The result is delivered as two arrays w(n) (the weight
! coefficients) and x(n) (the abscissae).  For a description of the method see
! H Rutishauser, ``On a modification of the QD-algorithm with Graeffe-type
! convergence'' [Proceedings of the IFIPS Congress, Munich, 1962].

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN)      :: q(n)
REAL (dp), INTENT(IN)      :: e(n-1)
REAL (dp), INTENT(IN OUT)  :: eps
REAL (dp), INTENT(OUT)     :: w(n)
REAL (dp), INTENT(OUT)     :: x(n)

! Allocate workspaces G & A
REAL (dp)  :: g(n), a(0:n,0:7)
!     ..
!     .. Local Scalars ..
REAL (dp)  :: m, p
INTEGER    :: k
!     ..
!     .. Intrinsic Functions ..
! INTRINSIC ABS,EXP,LOG
!     ..

x(1) = q(1) + e(1)
DO k = 2,n
  g(k-1) = e(k-1)*q(k)/x(k-1)
  IF (k == n) THEN
    x(k) = q(k) - g(k-1)

  ELSE
    x(k) = q(k) + e(k) - g(k-1)
  END IF

  g(k-1) = g(k-1)/x(k)
  w(k-1) = x(k)/x(k-1)
  x(k-1) = LOG(x(k-1))
END DO
x(n) = LOG(x(n))
p = 1
30  DO k = 1,n - 1
  IF (ABS(g(k)*w(k)) > eps) GO TO 40
END DO
GO TO 50

40 CALL qdgraeffe(n, x, g, w, a)
p = 2*p
GO TO 30

! What follows is a peculiar method to compute the w(k) from
! the given ratios g_k = w_{k+1}/w_k such that
!  \sum_{k=1}^n w_k = 1, but the straightforward formulae to do
! this might well produce overflow of exponent

50 w(1) = 1
m = 0
DO k = 1,n - 1
  w(k+1) = w(k)*g(k)
  IF (w(k) > m) m = w(k)
END DO
! WRITE (6,FMT=*) 'm=',m
m = SUM( w(1:n) )
DO k = 1,n
  w(k) = w(k)/m
  x(k) = EXP(x(k)/p)
END DO
RETURN

END SUBROUTINE weightc

SUBROUTINE red(a, f, n)

!  Subroutine RED reduces a heptadiagonal matrix a to tridiagonal form as
!  described in the paper referenced above.

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: a(0:n,0:7)
REAL (dp), INTENT(IN)      :: f(n)

!     ..
REAL (dp)  :: c
INTEGER    :: j, k
!     ..
!     .. Intrinsic Functions ..
! INTRINSIC ABS
!     ..
DO k = 1,n - 1
  DO j = k,n - 1

    c = -f(j)*a(j,7)/a(j,2)
    a(j,7) = 0
    a(j+1,2) = a(j+1,2) + c*a(j,5)
    a(j,1) = a(j,1) - c*f(j)*a(j,4)
    a(j,6) = a(j,6) - c*a(j+1,1)
    a(j+1,3) = a(j+1,3) - c*a(j+1,6)
  END DO
  DO j = k,n - 1
    c = -f(j)*a(j,4)/a(j,1)
    a(j,4) = 0
    a(j+1,1) = a(j+1,1) + c*a(j,6)
    a(j+1,6) = a(j+1,6) + c*a(j+1,3)
    a(j,5) = a(j,5) - c*a(j+1,2)
    a(j+1,0) = a(j+1,0) - c*a(j+1,5)
  END DO
  DO j = k + 1,n - 1
    c = -a(j,3)/a(j-1,6)
    a(j,3) = 0
    a(j,6) = a(j,6) + c*a(j,1)
    a(j-1,5) = a(j-1,5) - c*f(j)*f(j)*a(j,0)
    a(j,2) = a(j,2) - c*f(j)*f(j)*a(j,5)
    a(j,7) = a(j,7) - c*f(j)*a(j+1,2)
  END DO
  DO j = k + 1,n - 1
    c = -a(j,0)/a(j-1,5)
    a(j,0) = 0
    a(j+1,2) = a(j+1,2) + c*f(j)*a(j,7)
    a(j,5) = a(j,5) + c*a(j,2)
    a(j,1) = a(j,1) - c*f(j)*f(j)*a(j,6)
    a(j,4) = a(j,4) - c*f(j)*a(j+1,1)
  END DO
END DO
RETURN

END SUBROUTINE red

SUBROUTINE qdgraeffe(n, h, g, f, a)

! Subroutine QDGRAEFFE computes for a given continued fraction
!     f(z) = { 1| \over |z} - {q_1 | \over |1} -
!      {e_1 | \over |z} - {q_2 | \over |1} -
!      {e_2 | \over |z} - \cdots - {q_n | \over |1}
! another one, the poles of which are the squares of the poles of f(z)
! However QDGRAEFFE uses not the coefficients q_1 ... q_n and
! e_1 ... e_{n-1} of f(z) but the quotients f_k = q_{k+1}/q_k and
! g_k = e_k/q_{k+1} for k=1,2,...,n-1 and the h_k = ln(abs(q_k)) for
! k=1,2,...,n, and the results are delivered in the same form.  Routine
! QDGRAEFFE can be used independently, but requires subroutine RED

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(OUT)  :: h(n)
REAL (dp), INTENT(OUT)  :: g(n)
REAL (dp), INTENT(OUT)  :: f(n)
REAL (dp), INTENT(OUT)  :: a(0:n,0:7)

!     ..
!     .. Local Scalars ..
INTEGER  :: k
!     ..
!     .. External Subroutines ..
! EXTERNAL red
!     ..

g(n) = 0
f(n) = 0
DO k = 1,n
  a(k-1,4) = 1.0_dp
  a(k-1,5) = 1.0_dp
  a(k,2) = 1 + g(k)*f(k)
  a(k,1) = 1 + g(k)*f(k)
  a(k,6) = g(k)
  a(k,7) = g(k)
  a(k,0) = 0.0_dp
  a(k,3) = 0.0_dp
END DO
a(n,5) = 0.0_dp

! The array a represents the heptadiagonal matrix Q of the paper
! cited above, but with the modifications needed to avoid large numbers
! and with a peculiar arrangement.

CALL red(a, f, n)
DO k = 1,n
  h(k) = 2*h(k) + LOG(ABS(a(k,1)*a(k,2)))
END DO
DO k = 1,n - 1
  f(k) = f(k)*f(k)*a(k+1,2)*a(k+1,1)/ (a(k,1)*a(k,2))
  g(k) = a(k,5)*a(k,6)/ (a(k+1,1)*a(k+1,2))
END DO
RETURN

END SUBROUTINE qdgraeffe

END MODULE Gauss_Weights

PROGRAM main

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-03  Time: 14:01:08

! Driver for  CACM Alg 125 Rutishauser
! Author M.Dow@anu.edu.au
!        ANUSF,  Australian National University
!        Canberra, Australia

! Tidied up to use workspace arrays, real parameter values
! and put through nag tools

! trh (20/07/97)

USE Gauss_Weights
IMPLICIT NONE

!     ..
!     .. Parameters ..
INTEGER, PARAMETER    :: nm = 100
REAL (dp), PARAMETER  :: zero=0.0D0, one=1.0D0, two=2.0D0, three=3.0D0
!     .. Local Scalars ..
REAL (dp)  :: a, b, eps, exact, s
INTEGER    :: i, n, p
!     ..
!     .. Local Arrays ..
REAL (dp) :: e(nm), q(nm), w(nm), x(nm)
!     ..
!     .. External Subroutines ..
! EXTERNAL weightcoeff
!     ..

10 WRITE (6, FMT=*) ' Enter n, eps: '
READ (5, FMT=*, END=20) n, eps
IF (eps <= zero) eps = 1.D-15
IF (n >= nm-1) STOP
WRITE (6, FMT=*) 'n=', n, ' eps=', eps

!  q,e for w=1/2 interval (0,2)
! Ref: W.Jones & W.Thron Continued Fractions ...
!      Encyclopedia of maths...vol 11 p24
!      Continued Fraction expansion of log(1+x),
! transformed to Rutishauser form p33

DO i = 2,nm
  q(i) = two*i*i/ (two*i* (two*i-one))
  e(i) = two*i*i/ (two*i* (two*i+one))
END DO
q(1) = one
e(1) = one/three
CALL weightc(n, q, e, eps, w, x)

! Adjust weights, zeros for w=1, interval (-1,1)
DO i = 1, n
  w(i) = two*w(i)
  x(i) = x(i) - one
END DO

DO i = 1, MIN(n,10)
  WRITE (6, FMT=9000) w(i), x(i)
END DO

! Check for x^4
p = 4
a = -one
b = one
exact = (b** (p+1)-a** (p+1))/ (p+1)
s = zero
DO i = 1, n
  s = s + w(i)*x(i)**p
END DO
WRITE (6, FMT=9010) p, exact, s, exact - s
GO TO 10

20 STOP

9000 FORMAT (f20.16, '  ', f20.16)
9010 FORMAT (i3, ' Exact=', f20.16, ' Quadrature=', f20.16, ' Error=', e14.7)
END PROGRAM main


	program noisepower
c
c       a program to calculte the total power (kinetic envergy) of
c       ambient noise in a specific period range
c
c       Wen-Tzong Liang
c       DMC-IES, Academia Sinica
c       2012/02/12
c
        character*80 inp_file,out_file,arg

        nargc=IArgC()
        if(nargc .ne. 4) then
          print *
          print *,'Usage: noisePower [inpfile] [outfile] [prd0] [prd1]'
          print *,'Ex.: noisePower test.inp test.out 2 8'
          print *,'     obtain power between periods of 2 and 8 sec'
          print *
          stop
        endif

        call getarg(1,inp_file)
        call getarg(2,out_file)
        call getarg(3,arg)
        read(arg,*) p0
        call getarg(4,arg)
        read(arg,*) p1

	open(1,file=inp_file)
        open(21,file=out_file)

c        print *,'Input period range [Pmin Pmax]:'
c        read(*,*) p0,p1
        p0=alog10(p0)
        p1=alog10(p1)
        print *,p0,p1

        sqrt2=sqrt(2.0)

        twopi=2.*3.14159265358979
        t0=1e30
        prd0=1e30
        prd1=-1e30
        sum=0.0
	do i = 1,100000000
	  read(1,*,end=100) t,prdl,db
          if(i.ne.1 .and. t.ne.t0) then
            write(21,*) t0,sum
            sum=0.0
          end if
          if(prdl.ge.p0 .and. prdl.le.p1) then
            Tc=10**prdl
            w=twopi/Tc
c           Ts=Tc/sqrt2
c           Tl=Tc*sqrt2
	    pwr=10**(db/10.)/w/w
c           convert acceleration power into velocity power
            prd0=amin1(prd0,Tc)
            prd1=amax1(prd1,Tc)
	    sum=sum+pwr
          endif
          t0=t
	end do

100     write(21,*) t,sum

        print *,'Period range in Tc: ',prd0,prd1
        print *,'      in Ts and Tl: ',prd0/sqrt2,prd1*sqrt2
        close(1)
        close(21)
	stop
	end


C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C--C O N S T I T U T I V E  M A T E R I A L S  S U B R O U T I N E S---C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE UMATELA                                               C
C     PROPS(1) - E                                                     C
C     PROPS(2) - NU                                                    C
C     PROPS(3) - RO                                                    C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE UMATELA(DDSDDE,PROPS,NPROPS,NTENS,NDI)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
C
      PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0)
C
      DIMENSION DDSDDE(NTENS, NTENS),PROPS(NPROPS)
C
C     ELASTIC PROPERTIES
C
      EMOD=PROPS(1)
      ENU=PROPS(2)
      EBULK3=EMOD/(ONE-TWO*ENU)
      EG2=EMOD/(ONE+ENU)
      EG=EG2/TWO
      EG3=THREE*EG
      ELAM=(EBULK3-EG2)/THREE
C
C     ELASTIC STIFFNESS
C
      DO K1=1, NDI
        DO K2=1, NDI
          DDSDDE(K2, K1)=ELAM
        END DO
        DDSDDE(K1, K1)=EG2+ELAM
      END DO
      DO K1=NDI+1, NTENS
        DDSDDE(K1, K1)=EG
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE UMATCOS                                               C
C
C       IN THE INPUT FILE THE PARAMATERS ARE DEFINED AS:               C
C                                                                      C
C       ID  7   BETA    CPOIS   RHO J   XI  GAMMA   MU_C               C
C                                                                      C
C       BETA:   CLASSICAL SHEAR WAVE SPEED  (>0)                       C
C       CPOIS:  POISSON COEFFICIENT  (-1,0.5)                          C
C       RHO:    MASS DENSITY  (>0)                                     C
C       J:      INERTIA MOMENT DENSITY (ROTATIONAL INERTIA)  (>0)      C
C       XI:     DAMPING FACTOR  (>0)                                   C
C       GAMMA:  MICROPOLAR DISTORSION MODULI  (>0)                     C
C       MU_C:   RELATIVE SHEAR MODULI                                  C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: JUAN GOMEZ                                               C
C     GRUPO DE MECANICA APLICADA- UNIVERSIDAD EAFIT                    C
C     LAST MOD: 25 AUGUST 2012 BY NICOLAS GUARIN                       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE UMATCOS(DDSDDE,PROPS,NPROPS,NTENS,NDI)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION DDSDDE(NTENS, NTENS),PROPS(NPROPS)
C
      PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0,FOUR=4.D0,
     1           SIX=6.0D0,ENUMAX=0.4999D0)
C
C**********************************************************************
C          M I C R O P O L A R     E L A S T I C I T Y
C**********************************************************************
C
C     Real elastic properties
C
      EG2 = TWO*PROPS(1)*PROPS(1)*PROPS(3)
      EG = EG2/TWO
      ENU = PROPS(2)
      EMOD = EG2*(ONE+ENU)
      ELAM = (ENU*EMOD)/((ONE+ENU)*(ONE-TWO*ENU))
      ELPNU = ELAM+EG2
      XI = PROPS(5)
      GAMMA = PROPS(6)
      EGC = PROPS(7)
C
C     Elastic complex stiffness
C
      DO K1=1, 3
        DO K2=1, 3
          DDSDDE(K2, K1)=ELAM
        END DO
        DDSDDE(K1, K1)=ELPNU
      END DO
      DDSDDE(4, 4) = EG+EGC
      DDSDDE(4, 5) = EG-EGC
      DDSDDE(5, 4) = DDSDDE(4, 5)
      DDSDDE(5, 5) = EG+EGC
      DDSDDE(6, 6) = GAMMA
      DDSDDE(7, 7) = GAMMA
C
      RETURN
C
      END
C


subroutine EigValVecSymTri(ain, n, eig, evec, ul)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will return the eigenvalues and eigenvectors
!	of the symmetric square tridiagonal matrix Ain. The output eigenvectors
!	are ordered from greatest to least, and the norm of the eigenvectors
!	is unity. The sign convention for the eigenvectors is that the
!	first value of each eigenvector is positive.
!
!	Calling Parameters
!		IN
!			Ain	Input symmetric tridiagonal matrix.
!			n	Order of the matrix Ain.
!		OUT
!			eig	Vector of length n of the eigenvalues of Ain.
!			evec	Matrix of dimension n of the
!				eigenvectors of Ain.
!		IN (OPTIONAL)
!			ul	Use the upper 'U' or lower 'L' portion of the
!				input symmetric matrix. By default, the lower portion
!				of the matrix will be used.
!
!	Notes:
!
!	1.	The tridiagonal matrix is reduced to  A = S L S'.
!	2.	If accuracy is a problem, consider changing the value of ABSTOL.
!		I have arbitrarily set this to zero, which forces the routines to
!		pick a default value (which may or may not be good).
!	3. 	The sign convention for the eigenvalues might want to be changed.
!		For instance, IMSL chooses the sign such that the value with
!		max(abs(evec)) is positive.
!
!	Dependencies: LAPACK, BLAS
!
!	Written by Mark Wieczorek June 2004.
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) ::	ain(:,:)
	integer, intent(in) ::	n
	real*8, intent(out) ::	eig(:), evec(:,:)
	character, intent(in), optional :: ul
	integer, parameter ::	nb = 80, nbl = 10
	real*8 ::	d(n), e(n), work(nb*n), vl, vu, abstol, w(n)
	real*8, allocatable ::	z(:, :)
	integer ::	lwork, info, il, iu, m, isuppz(2*n), liwork, iwork(nbl*n), i, astat
	external 	dstegr_

	if (size(ain(:,1)) < n .or. size(ain(1,:)) < n) then
		print*, "Error --- EigValVecSymTri"
		print*, "AIN must be dimensioned as (N, N) where N is ", n
		print*, "Input array is dimensioned as ", size(ain(:,1)), size(ain(1,:))
		stop
	elseif(size(eig) < n) then
		print*, "Error --- EigValVecSymTri"
		print*, "EIG must be dimensioned as (N) where N is ", n
		print*, "Input array is dimensioned as ", size(eig)
		stop
	elseif(size(evec(:,1)) < n .or. size(evec(1,:)) < n) then
		print*, "Error --- EigValVecSymTri"
		print*, "EVEC must be dimensioned as (N, N) where N is ", n
		print*, "Input array is dimensioned as ", size(evec(:,1)), size(evec(1,:))
		stop

	endif

	allocate(z(n, n), stat = astat)
	if (astat /= 0) then
		print*, "Error --- EigValVecSymTri"
		print*, "Problem allocating arrays Z", astat
		stop
	endif

	lwork = nb*n
	liwork = nbl*n

	eig = 0.0d0
	evec = 0.0d0

	d(1) = ain(1,1)

	if (present(ul)) then
		if (ul == "U" .or. ul == "u") then
			do i=2, n, 1
				d(i) = ain(i,i)
				e(i-1) = ain(i-1, i)
			enddo
		elseif(ul =="L" .or. ul == "l") then
			do i=2, n, 1
				d(i) = ain(i,i)
				e(i-1) = ain(i, i-1)
			enddo
		else
			print*, "Error --- EigValVecSym"
			print*, "UL must be either U, u, L, or l"
			print*, "Input value is ", ul
			stop
		endif
	else

		do i=2, n, 1
			d(i) = ain(i,i)
			e(i-1) = ain(i, i-1)
		enddo
	endif

	e(n) = 0.0d0

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Factor tridiagonal matric A = S L S', and re-order
	!	eignevalues and vectors from greatest to least.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	abstol = 0.0d0

	call dstegr_('v','a', n, d, e, vl, vu, il, iu, abstol, m,  w, &
			z, n, isuppz, work, lwork, iwork, liwork, info)

       	if (info /= 0) then
		print*, "Error --- EigValVecSymTri"
		print*, "Problem determining eigenvalues and eigenvectors of tridiagonal matrix."
		if (info==1) print*, "Internal error in DLARRE"
		if (info==2) print*, "Internal error in DLARRV"
		stop
	else
		if (work(1) > dble(lwork) ) then
			print*, "Warning --- EigValVecSymTri"
			print*, "Consider changing value of nb to ", work(1)/n, " and recompile SHTOOLS archive."
		endif

		if (iwork(1) > liwork ) then
			print*, "Warning --- EigValVecSymTri"
			print*, "Consider changing value of nb to ", iwork(1)/n, " and recompile SHTOOLS archive."
		endif
	endif

	do i=1, n
		eig(i) = w(n+1-i)
		evec(1:n,i) = z(1:n,n+1-i)
		if (evec(1,i) < 0.0d0) evec(1:n,i) = -evec(1:n,i)
	enddo

	deallocate(z)

end subroutine EigValVecSymTri


! Like array_alloc_1.f90, but check cases in which the array length is
! not a literal constant.
! { dg-do run }
program main
  implicit none
  integer, parameter :: n = 100
  call test (n, f1 ())
  call test (47, f2 (50))
  call test (n, f3 (f1 ()))
contains
  subroutine test (expected, x)
    integer, dimension (:) :: x
    integer :: i, expected
    if (size (x, 1) .ne. expected) call abort
    do i = 1, expected
      if (x (i) .ne. i * 100) call abort
    end do
  end subroutine test

  function f1 ()
    integer, dimension (n) :: f1
    integer :: i
    forall (i = 1:n) f1 (i) = i * 100
  end function f1

  function f2 (howmuch)
    integer :: i, howmuch
    integer, dimension (4:howmuch) :: f2
    forall (i = 4:howmuch) f2 (i) = i * 100 - 300
  end function f2

  function f3 (x)
    integer, dimension (:) :: x
    integer, dimension (size (x, 1)) :: f3
    integer :: i
    forall (i = 1:size(x)) f3 (i) = i * 100
  end function f3
end program main


    Program dtgsyl_example

!     DTGSYL Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dtgsyl
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: dif, scale
      Integer :: i, ifail, ijob, info, lda, ldb, ldc, ldd, lde, ldf, lwork, m, &
        n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), c(:, :), d(:, :), &
        e(:, :), f(:, :), work(:)
      Integer, Allocatable :: iwork(:)
!     .. Executable Statements ..
      Write (nout, *) 'DTGSYL Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldb = n
      ldc = m
      ldd = m
      lde = n
      ldf = m
      lwork = 1
      Allocate (a(lda,m), b(ldb,n), c(ldc,n), d(ldd,m), e(lde,n), f(ldf,n), &
        work(lwork), iwork(m+n+6))

!     Read A, B, D, E, C and F from data file

      Read (nin, *)(a(i,1:m), i=1, m)
      Read (nin, *)(b(i,1:n), i=1, n)
      Read (nin, *)(d(i,1:m), i=1, m)
      Read (nin, *)(e(i,1:n), i=1, n)
      Read (nin, *)(c(i,1:n), i=1, m)
      Read (nin, *)(f(i,1:n), i=1, m)

!     Solve the Sylvester equations
!         A*R - L*B = scale*C and D*R - L*E = scale*F
!     for R and L.
      ijob = 0

      Call dtgsyl('No transpose', ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, &
        e, lde, f, ldf, scale, dif, work, lwork, iwork, info)

      If (info>=1) Then
        Write (nout, 100)
        Write (nout, *)
        Flush (nout)
      End If

!     Print the solution matrices R and L

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', m, n, c, ldc, &
        'Solution matrix R', ifail)

      Write (nout, *)
      Flush (nout)

      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', m, n, f, ldf, &
        'Solution matrix L', ifail)

      Write (nout, *)
      Write (nout, 110) 'SCALE = ', scale

100   Format (/, ' (A,D) and (B,E) have common or very close eigenval', &
        'ues.', /, ' Perturbed values were used to solve the equations')
110   Format (1X, A, 1P, E10.2)
    End Program


module constants
  real*8, parameter :: pi = acos(-1.0d0)

  ! divide an energy in electron volts by eV to convert to hartrees,
  ! and vice-versa
  real*8, parameter :: eV = 27.2114d0
end module constants


program allocate_01
implicit none
integer, allocatable :: a(:)
real, allocatable :: b(:, :)
complex, allocatable :: c(:, :, :)
complex :: r
integer :: n, ierr
integer :: i, j, k
n = 10
allocate(a(5:n + 5))
allocate(b(n:2*n, n:3*n), stat=ierr)
if( size(a) /= n + 1 ) error stop
if( size(b) /= (n + 1)*(2*n + 1) ) error stop
do i = lbound(a, 1), ubound(a, 1)
    a(i) = i
end do
do i = lbound(b, 1), ubound(b, 1)
    do j = lbound(b, 2), ubound(b, 2)
        b(i, j) = i + j
    end do
end do

call sum(a, b, c)

do i = lbound(a, 1), ubound(a, 1)
    if (a(i) /= i) error stop
end do
do i = lbound(b, 1), ubound(b, 1)
    do j = lbound(b, 2), ubound(b, 2)
        if (b(i, j) /= i + j) error stop
    end do
end do
do i = lbound(c, 1), ubound(c, 1)
    do j = lbound(c, 2), ubound(c, 2)
        do k = lbound(c, 3), ubound(c, 3)
            if (c(i, j, k) /= i + j + k) error stop
        end do
    end do
end do

r = reduce_sum(c)
if (r /= (114345.0, 0.0)) error stop

contains

subroutine sum(a, b, c)
implicit none

integer, allocatable, intent(in) :: a(:)
real, allocatable, intent(in) :: b(:, :)
complex, allocatable, intent(out) :: c(:, :, :)
integer :: i, j, k

complex, allocatable :: c_copy(:, :, :)

allocate(c_copy(lbound(a, 1):ubound(a, 1), lbound(b, 1):ubound(b, 1), lbound(b, 2):ubound(b, 2)))
allocate(c(lbound(a, 1):ubound(a, 1), lbound(b, 1):ubound(b, 1), lbound(b, 2):ubound(b, 2)))

do i = lbound(a, 1), ubound(a, 1)
    do j = lbound(b, 1), ubound(b, 1)
        do k = lbound(b, 2), ubound(b, 2)
            c_copy(i, j, k) = a(i) + b(j, k)
            c(i, j, k) = a(i) + b(j, k)
        end do
    end do
end do

deallocate(c_copy)

end subroutine sum

complex function reduce_sum(c) result(r)
implicit none

complex, intent(in) :: c(:, :, :)
integer :: i, j, k

r = 0

do i = lbound(c, 1), ubound(c, 1)
    do j = lbound(c, 2), ubound(c, 2)
        do k = lbound(c, 3), ubound(c, 3)
            r = r + c(i, j, k)
        end do
    end do
end do

end function reduce_sum

end


      PROGRAM MAIN
      USE global
      IMPLICIT NONE
      INTEGER :: IC

      CALL input
      CALL initial
      CALL perturbation_gaussian
      J=0
      CALL datawriting
      DO 99 J = 1, NTIME
      CALL CONTINUTYn(NI,VXI, PI, EX, ZI, MI, 2, 1)
      CALL CONTINUTYn(NE,VXE, PE, EX, ZE, ME, 2, 1)
      CALL poisson_sol_E2(NI(2,:), NE(2,:), EX(2,:))
      CALL poisson_sol_PHI(PH(2,:), EX(2,:))
      CALL CONTINUTYn(NI,VXI, PI, EX, ZI, MI, 1, 2)
      CALL CONTINUTYn(NE,VXE, PE, EX, ZE, ME, 1, 2)
      CALL poisson_sol_E2(NI(1,:), NE(1,:), EX(1,:))
      CALL poisson_sol_PHI(PH(1,:), EX(1,:))
      IF (MOD(J, TIDATA)==0) THEN
      CALL datawriting
      END IF
   99 CONTINUE

      END PROGRAM MAIN


!*****************************************************************!
!                            Melissa                              !
!-----------------------------------------------------------------!
!   COPYRIGHT (C) 2017  by INRIA and EDF. ALL RIGHTS RESERVED.    !
!                                                                 !
! This source is covered by the BSD 3-Clause License.             !
! Refer to the  LICENCE file for further information.             !
!                                                                 !
!-----------------------------------------------------------------!
!  Original Contributors:                                         !
!    Theophile Terraz,                                            !
!    Bruno Raffin,                                                !
!    Alejandro Ribes,                                             !
!    Bertrand Iooss,                                              !
!*****************************************************************!

program heat

  use heat_utils
  use iso_c_binding, only: C_CHAR, C_NULL_CHAR

  implicit none

  include "melissa_api.f90"

  integer :: i, j, k, nx, ny, n, nmax, me, np, i1, iN, statinfo, vect_size, next, previous, narg
  integer, dimension(mpi_status_size) :: status
  real*8 :: lx, ly, dt, dx, dy, d, t, epsilon, t1, t2
  real*8, dimension(:), pointer :: U => null(), F => null()
  real*8, dimension(3) :: A
  real*8,dimension(5) :: param
  character(len=32) :: arg
  integer :: comm
  integer(kind=MPI_ADDRESS_KIND) :: appnum
  character(len=5) :: name = C_CHAR_"heat1"  !C_NULL_CHAR

  call mpi_init(statinfo)

  ! The program now takes at least 2 parameter:
  ! - The coupling method for Sobol' groups
  ! - the initial temperature

  narg = iargc()
  param(:) = 0
  if (narg .lt. 2) then
    print*,"Missing parameter"
    stop
  endif

  param(:) = 0.

  ! The initial temperature is stored in param(1)
  ! The four next optional parameters are the boundary temperatures
  do n=1, 5
    if(narg .ge. n) then
      call getarg(n, arg)
      read( arg, * ) param(n)
    endif
  enddo

  ! The new MPI communicator is build by splitting MPI_COMM_WORLD by simulation inside the group.
  ! In the case of a single simulation group, this is equivalent to MPI_Comm_dup.
  call mpi_comm_rank(MPI_COMM_WORLD, me, statinfo)
  call MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_APPNUM, appnum, statinfo);
  call MPI_Comm_split(MPI_COMM_WORLD, appnum, me, comm, statinfo);
  call mpi_comm_rank(comm, me, statinfo)
  call mpi_comm_size(comm, np, statinfo)

  ! Init timer
  t1=mpi_wtime()

  ! Neighbour ranks
  next = me+1
  previous = me-1

  if(next == np)     next=mpi_proc_null
  if(previous == -1) previous=mpi_proc_null

  nx        = 100 ! x axis grid subdivisions
  ny        = 100 ! y axis grid subdivisions
  lx        = 10.0 ! x length
  ly        = 10.0 ! y length
  d         = 1.0 ! diffusion coefficient
  dt        = 0.01 ! timestep value
  nmax      = 100 ! number of timesteps
  dx        = lx/(nx+1) ! x axis step
  dy        = ly/(ny+1) ! y axis step
  epsilon   = 0.0001 ! conjugated gradient precision
  n         = nx*ny ! number of cells in the drid

  ! work repartition over the MPI processes
  ! i1 and in: first and last global cell indices atributed to this process
  call load(me, nx*ny, Np, i1, iN)

  ! local number of cells
  vect_size = in-i1+1

  ! initialization
  allocate(U(in-i1+1))
  allocate(F(in-i1+1))
  ! we will solve Au=F
  call init(U, i1, iN, dx, dy, nx, lx, ly, param(1))
  ! init A (tridiagonal matrix):
  call filling_A(d, dx, dy, dt, nx, ny, A) ! fill A

  ! melissa_init is the first Melissa function to call, and it is called only once by each process in comm.
  ! It mainly contacts the server.
  call melissa_init (name, vect_size, comm)

  ! main loop:
  do n=1, nmax
    t = t + dt
    ! filling F (RHS) before each iteration:
    call filling_F(nx, ny, U, d, dx, dy, dt, t, F, i1, in, lx, ly, param)
    ! conjugated gradient to solve Au = F.
    call conjgrad(A, F, U, nx, ny, epsilon, i1, in, np, me, next, previous, comm)
    ! The result is u
    ! melissa_send is called at each iteration to send u to the server.
    call melissa_send(name, u)
  end do

  ! melissa_finalize closes the connexion with the server.
  ! No Melissa function should be called after melissa_finalize.
  call melissa_finalize ()

  t2 = mpi_wtime()
  print*, 'Calcul time:', t2-t1, 'sec'
  print*, 'Final time step:', t

  deallocate(U, F)

  call mpi_finalize(statinfo)

end program heat


c=======================================================================
c     subroutine JAMESSTREIN
c
c     James-Stein expected return - shrinkage estimator
c
c     mu = (1 - intensity)*mu + intensity*target
c
c     mu        : expected return
c     intensity : shrinkage intensity
c     target    : shrinkage taget
c
c----------------------------------------------------------------------
      SUBROUTINE jamesstein ( n, p, cov, rho, iwork, dwork, mu, info )
c----------------------------------------------------------------------
c
c     INPUT
c       n     : number of observations (n>1)                   integer
c       p     : portfolio size (p>1)                           integer
c       cov   : covariance matrix (p*p)                         double
c       rho   : expected return (p)                             double
c
c     WORKSPACES
c       iwork : 12*p + 3                                       integer
c       dwork : p*(19*p + 63)/2 + 2                             double
c
c     OUTPUT
c       mu    : James-Stein estimator (p)                       double
c       info  : diagnostic argument                            integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION mu(*), rho(*), cov(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
      INTEGER iwork(*)
c
c     local variables
      INTEGER i, mcte, pisdls, pdcov, pdsdls, pdA, pdb, pdinvC, pdjms,
     &        pdv, pdones
      DOUBLE PRECISION x, y, t, w, epsbfg, alpha, EPS, ZERO, ONE, m
      PARAMETER ( EPS = 1.E-30, ZERO = 0.0, ONE = 1.0 )
c
c     external subroutines
      EXTERNAL sdls, IVX, JMS, OVTMCV, PMV, SEV
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      CALL IVX ( p, mu, ZERO )
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      pisdls = 1
c     pisdls : pointer for SDLS workspaces (12*p + 3)
c
c     Total size of dwork array = 12*p + 3
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdcov  = 1
c     pdcov  : pointer for temporary cov. matrix (p*p)
      pdsdls = pdcov + ( p*p )
c     pdsdls : pointer for SDLS workspaces (p*(p+1)*5/2 + p*(4*p + 27))
      pdA    = pdsdls + ( p*(p+1)*5/2 + p*(4*p + 27) )
c     pdA    : pointer for constraint matrix (1)
      pdb    = pdA + ( 1 )
c     pdb    : pointer for constraint vector (1)
      pdjms  = pdb + ( 1 )
c     pdjms  : pointer for JMS workspaces (p*p)
      pdinvC = pdjms + ( p*p )
c     pdinvC : pointer for inverse cov. matrix (p*p)
      pdones = pdinvC + ( p*p )
c     pdones : pointer for ones vector (p)
      pdv   = pdones + ( p )
c     pdv   : pointer for temporary vector (p)
c
c     Total size of dwork array = 2*p*(p + 1)
c                               = p*(19*p + 63)/2 + 2
c
c----------------------------------------------------------------------
c
c     shrinkage target
c     inv(cov)
      CALL IVX ( p, dwork(pdones), ONE )
      CALL JMS ( p, cov, dwork(pdjms), dwork(pdinvC), info )
c
c     matrix correction to ensure definite positivity
      IF (info .NE. 0) THEN
        mcte = 0        ! number of constraints
        epsbfg = 1.E-8  ! BFGS precision stop test
        alpha  = 1.E-8  ! minimum eigenvalue
        CALL sdls ( p, cov, mcte, dwork(pdA), dwork(pdb), epsbfg, alpha,
     &              iwork(pisdls), dwork(pdsdls), dwork(pdcov), info )
        CALL JMS ( p, dwork(pdcov), dwork(pdjms), dwork(pdinvC), info )
      ENDIF
c
c     1'*inv(cov)*1
      CALL OVTMCV (p, dwork(pdinvC), dwork(pdones), y )
      IF (y .LT. EPS) THEN
        info = -1
        RETURN
      ENDIF
c
c     1'*inv(cov)*rho
c     matrix vector multiply: U(p) = A(p,p)*V(p)
      CALL PMV ( p, p, dwork(pdinvC), rho, dwork(pdv) )
      CALL SEV ( p, dwork(pdv), x )
c
c     global minimum variance portfolio
c     target (1'*inv(cov)*rho)/(1'*inv(cov)*1)
      t = x/y
c
c     shrinkage intensity
c     (p+2)/(p+2+(n*(n-1)/(n-p-2))*(rho-t)'*inv(cov)*(rho-t))
      DO i = 1,p
        dwork(pdv + i - 1) = rho(i) - t
      ENDDO
      CALL OVTMCV (p, dwork(pdinvC), dwork(pdv), x )
      IF ((N-p-2.0).LT.EPS) THEN
        info = -1
        RETURN
      ENDIF
      m = (N*(N-1.0))/(N-p-2.0)
      w = (p + 2.0)/(p + 2.0 + m*x)
c
c     James-Stein shrinkage estimator
      DO i = 1,p
        mu(i) = (1 - w)*rho(i) + w*t
      ENDDO
      RETURN
      END


use ArrayClass
use IOClass
implicit none

real(real64) :: lx,ly
real(real64),allocatable :: space(:,:),func(:)
type(IO_) :: f

! f(x,y) = 1 if |x|<lx, |y|<ly
! f(x,y) = 0 otherwise

! Visualize F(wx,wy) : 2D Fourier Spectre of f(x,y)

lx = 1.0d0
ly = 1.0d0

space = linspace(            &
    xrange=[-10.0d0,10.0d0], &
    yrange=[-10.0d0,10.0d0], &
    xnum = 100,              &
    ynum = 100               &
    )

func = zeros(size(space,1) )
func = 4.0d0*sin(lx*space(:,1) )/space(:,1)*sin(ly*space(:,2) )/space(:,2)

call f%open("2DFourierSpectre.txt","w")
call f%write(space(:,1),space(:,2),func(:) )
call f%close()
call f%splot(option="with lines")

end


      DOUBLE PRECISION FUNCTION DVMAG (V1,EPS)
C
C     RETURNS DOUBLE PRECISION MAGNITUDE OF VECTOR V1
C        DVMAG= 0.D0 WHEN .LE. EPS
C
      DOUBLE PRECISION V1(3), A, EPS, DADOTB
C
C
      DVMAG= 0.D0
      A= DADOTB(V1,V1)
      IF (A .GT. 0.D0) DVMAG= DSQRT(A)
      IF ( DVMAG .LE. EPS)             DVMAG= 0.D0
      RETURN
      END


      SUBROUTINE wwghts(wghts,n,h,kermom)
      INTEGER n
      REAL wghts(n),h
      EXTERNAL kermom
CU    USES kermom
      INTEGER j,k
      DOUBLE PRECISION wold(4),wnew(4),w(4),hh,hi,c,fac,a,b
      hh=h
      hi=1.d0/hh
      do 11 j=1,n
        wghts(j)=0.
11    continue
      call kermom(wold,0.d0,4)
      if (n.ge.4) then
        b=0.d0
        do 14 j=1,n-3
          c=j-1
          a=b
          b=a+hh
          if (j.eq.n-3) b=(n-1)*hh
          call kermom(wnew,b,4)
          fac=1.d0
          do 12 k=1,4
            w(k)=(wnew(k)-wold(k))*fac
            fac=fac*hi
12        continue
          wghts(j)=wghts(j)+((c+1.d0)*(c+2.d0)*(c+3.d0)*w(1)-(11.d0+c*
     *(12.d0+c*3.d0))*w(2)+3.d0*(c+2.d0)*w(3)-w(4))/6.d0
          wghts(j+1)=wghts(j+1)+(-c*(c+2.d0)*(c+3.d0)*w(1)+(6.d0+c*
     *(10.d0+c*3.d0))*w(2)-(3.d0*c+5.d0)*w(3)+w(4))*.5d0
          wghts(j+2)=wghts(j+2)+(c*(c+1.d0)*(c+3.d0)*w(1)-(3.d0+c*(8.d0+
     *c*3.d0))*w(2)+(3.d0*c+4.d0)*w(3)-w(4))*.5d0
          wghts(j+3)=wghts(j+3)+(-c*(c+1.d0)*(c+2.d0)*w(1)+(2.d0+c*
     *(6.d0+c*3.d0))*w(2)-3.d0*(c+1.d0)*w(3)+w(4))/6.d0
          do 13 k=1,4
            wold(k)=wnew(k)
13        continue
14      continue
      else if (n.eq.3) then
        call kermom(wnew,hh+hh,3)
        w(1)=wnew(1)-wold(1)
        w(2)=hi*(wnew(2)-wold(2))
        w(3)=hi**2*(wnew(3)-wold(3))
        wghts(1)=w(1)-1.5d0*w(2)+0.5d0*w(3)
        wghts(2)=2.d0*w(2)-w(3)
        wghts(3)=0.5d0*(w(3)-w(2))
      else if (n.eq.2) then
        call kermom(wnew,hh,2)
        wghts(2)=hi*(wnew(2)-wold(2))
        wghts(1)=wnew(1)-wold(1)-wghts(2)
      endif
      END

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


 SUBROUTINE POLATES3(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
                     IGDTNUMO,IGDTMPLO,IGDTLENO, &
                     MI,MO,KM,IBI,LI,GI, &
                     NO,RLAT,RLON,IBO,LO,GO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! SUBPROGRAM:  POLATES3   INTERPOLATE SCALAR FIELDS (BUDGET)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS BUDGET INTERPOLATION
!           FROM ANY GRID TO ANY GRID (OR TO RANDOM STATION
!           POINTS) FOR SCALAR FIELDS.  THE ALGORITHM
!           SIMPLY COMPUTES (WEIGHTED) AVERAGES OF
!           BILINEARLY INTERPOLATED POINTS ARRANGED IN A SQUARE BOX
!           CENTERED AROUND EACH OUTPUT GRID POINT AND STRETCHING
!           NEARLY HALFWAY TO EACH OF THE NEIGHBORING GRID POINTS.
!           OPTIONS ALLOW CHOICES OF NUMBER OF POINTS IN EACH RADIUS
!           FROM THE CENTER POINT (IPOPT(1)) WHICH DEFAULTS TO 2
!           (IF IPOPT(1)=-1) MEANING THAT 25 POINTS WILL BE AVERAGED;
!           FURTHER OPTIONS ARE THE RESPECTIVE WEIGHTS FOR THE RADIUS
!           POINTS STARTING AT THE CENTER POINT (IPOPT(2:2+IPOPT(1))
!           WHICH DEFAULTS TO ALL 1 (IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!           A SPECIAL INTERPOLATION IS DONE IF IPOPT(2)=-2.
!           IN THIS CASE, THE BOXES STRETCH NEARLY ALL THE WAY TO
!           EACH OF THE NEIGHBORING GRID POINTS AND THE WEIGHTS
!           ARE THE ADJOINT OF THE BILINEAR INTERPOLATION WEIGHTS.
!           THIS CASE GIVES QUASI-SECOND-ORDER BUDGET INTERPOLATION.
!           ANOTHER OPTION IS THE MINIMUM PERCENTAGE FOR MASK,
!           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
!           (IPOPT(3+IPOPT(1)) WHICH DEFAULTS TO 50 (IF -1).
!           IN CASES WHERE THERE IS NO OR INSUFFICIENT VALID INPUT DATA,
!           THE USER MAY CHOOSE TO SEARCH FOR THE NEAREST VALID DATA.
!           THIS IS INVOKED BY SETTING IPOPT(20) TO THE WIDTH OF
!           THE SEARCH SQUARE. THE DEFAULT IS 1 (NO SEARCH).  SQUARES ARE
!           SEARCHED FOR VALID DATA IN A SPIRAL PATTERN
!           STARTING FROM THE CENTER.  NO SEARCHING IS DONE WHERE
!           THE OUTPUT GRID IS OUTSIDE THE INPUT GRID.
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!
!           THE CODE RECOGNIZES THE FOLLOWING PROJECTIONS, WHERE
!           "IGDTNUMI/O" IS THE GRIB 2 GRID DEFINTION TEMPLATE NUMBER
!           FOR THE INPUT AND OUTPUT GRIDS, RESPECTIVELY:
!             (IGDTNUMI/O=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUMI/O=01) ROTATED EQUIDISTANT CYLINDRICAL. "E" AND
!                             NON-"E" STAGGERED
!             (IGDTNUMI/O=10) MERCATOR CYLINDRICAL
!             (IGDTNUMI/O=20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUMI/O=30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUMI/O=40) GAUSSIAN CYLINDRICAL
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED.
!           ON THE OTHER HAND, THE OUTPUT CAN BE A SET OF STATION POINTS
!           IF IGDTNUMO=IGDTNUMO-255, IN WHICH CASE THE NUMBER OF POINTS
!           AND THEIR LATITUDES AND LONGITUDES MUST BE INPUT.
!
!           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
!           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 1999-04-08  IREDELL  ADDED BILINEAR OPTION IPOPT(2)=-2
! 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
! 2006-01-04  GAYNO    ADDED OPTION TO DO SUBSECTION OF OUTPUT GRID.
!                      ADDED SPIRAL SEARCH OPTION.
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      VERSION OF GDSWZD.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAYS
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAYS.
!
! USAGE:    CALL POLATES3(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
!                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
!                         MI,MO,KM,IBI,LI,GI, &
!                         NO,RLAT,RLON,IBO,LO,GO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1) IS NUMBER OF RADIUS POINTS
!                (DEFAULTS TO 2 IF IPOPT(1)=-1);
!                IPOPT(2:2+IPOPT(1)) ARE RESPECTIVE WEIGHTS
!                (DEFAULTS TO ALL 1 IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!                IPOPT(3+IPOPT(1)) IS MINIMUM PERCENTAGE FOR MASK
!                (DEFAULTS TO 50 IF IPOPT(3+IPOPT(1)=-1)
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE:
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE. IGDTNUMO=IGDTNUM-255
!                MEANS INTERPOLATE TO RANDOM STATION POINTS.
!                OTHERWISE, SAME DEFINITION AS "IGDTNUMI".
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     GI       - REAL (MI,KM) INPUT FIELDS TO INTERPOLATE
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO=IGDTNUMO-255)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO=IGDTNUMO-255)
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (ONLY IF IGDTNUMO>=0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (ONLY IF IGDTNUMO>=0)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     GO       - REAL (MO,KM) OUTPUT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!                32   INVALID BUDGET METHOD PARAMETERS
!
! SUBPROGRAMS CALLED:
!   GDSWZD       GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0      SET UP PARAMETERS FOR IJKGDS1
!   IJKGDS1      RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   POLFIXS      MAKE MULTIPLE POLE SCALAR VALUES CONSISTENT
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 USE GDSWZD_MOD

 IMPLICIT NONE
!
 INTEGER,    INTENT(IN   )     :: IGDTNUMI, IGDTLENI
 INTEGER,    INTENT(IN   )     :: IGDTMPLI(IGDTLENI)
 INTEGER,    INTENT(IN   )     :: IGDTNUMO, IGDTLENO
 INTEGER,    INTENT(IN   )     :: IGDTMPLO(IGDTLENO)
 INTEGER,    INTENT(IN   )     :: IBI(KM), IPOPT(20)
 INTEGER,    INTENT(IN   )     :: KM, MI, MO
 INTEGER,    INTENT(  OUT)     :: IBO(KM), IRET, NO
!
 LOGICAL*1,  INTENT(IN   )     :: LI(MI,KM)
 LOGICAL*1,  INTENT(  OUT)     :: LO(MO,KM)
!
 REAL,       INTENT(IN   )     :: GI(MI,KM)
 REAL,       INTENT(INOUT)     :: RLAT(MO), RLON(MO)
 REAL,       INTENT(  OUT)     :: GO(MO,KM)
!
 REAL,       PARAMETER         :: FILL=-9999.
!
 INTEGER                       :: IJKGDS1, I1, J1, I2, J2, IB, JB
 INTEGER                       :: IJKGDSA(20), IX, JX, IXS, JXS
 INTEGER                       :: K, KXS, KXT, IGDTNUMO2
 INTEGER                       :: LB, LSW, MP, MSPIRAL, MX
 INTEGER                       :: N, NB, NB1, NB2, NB3, NB4, NV, NX
 INTEGER                       :: N11(MO),N21(MO),N12(MO),N22(MO)
!
 REAL                          :: GB, LAT(1), LON(1)
 REAL                          :: PMP, RB2, RLOB(MO), RLAB(MO), WB
 REAL                          :: W11(MO), W21(MO), W12(MO), W22(MO)
 REAL                          :: WO(MO,KM), XF, YF, XI, YI, XX, YY
 REAL                          :: XPTS(MO),YPTS(MO),XPTB(MO),YPTB(MO)
 REAL                          :: XXX(1), YYY(1)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
!  DO SUBSECTION OF GRID IF KGDSO(1) IS SUBTRACTED FROM 255.
 IRET=0
 IF(IGDTNUMO.GE.0) THEN
   CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO)
   IF(NO.EQ.0) IRET=3
 ELSE
   IGDTNUMO2=255+IGDTNUMO
   CALL GDSWZD(IGDTNUMO2,IGDTMPLO,IGDTLENO,-1,MO,FILL,XPTS,YPTS,RLON,RLAT,NO)
   IF(NO.EQ.0) IRET=3
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 IF(IPOPT(1).GT.16) IRET=32
 MSPIRAL=MAX(IPOPT(20),1)
 NB1=IPOPT(1)
 IF(NB1.EQ.-1) NB1=2
 IF(IRET.EQ.0.AND.NB1.LT.0) IRET=32
 LSW=1
 IF(IPOPT(2).EQ.-2) LSW=2
 IF(IPOPT(1).EQ.-1.OR.IPOPT(2).EQ.-1) LSW=0
 IF(IRET.EQ.0.AND.LSW.EQ.1.AND.NB1.GT.15) IRET=32
 MP=IPOPT(3+IPOPT(1))
 IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
 IF(MP.LT.0.OR.MP.GT.100) IRET=32
 PMP=MP*0.01
 IF(IRET.EQ.0) THEN
   NB2=2*NB1+1
   RB2=1./NB2
   NB3=NB2*NB2
   NB4=NB3
   IF(LSW.EQ.2) THEN
     RB2=1./(NB1+1)
     NB4=(NB1+1)**4
   ELSEIF(LSW.EQ.1) THEN
     NB4=IPOPT(2)
     DO IB=1,NB1
       NB4=NB4+8*IB*IPOPT(2+IB)
     ENDDO
   ENDIF
 ELSE
   NB3=0
   NB4=1
 ENDIF
 DO K=1,KM
   DO N=1,NO
     GO(N,K)=0.
     WO(N,K)=0.
   ENDDO
 ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX
 CALL IJKGDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IJKGDSA)
 DO NB=1,NB3
!  LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS
   JB=(NB-1)/NB2-NB1
   IB=NB-(JB+NB1)*NB2-NB1-1
   LB=MAX(ABS(IB),ABS(JB))
   WB=1
   IF(LSW.EQ.2) THEN
     WB=(NB1+1-ABS(IB))*(NB1+1-ABS(JB))
   ELSEIF(LSW.EQ.1) THEN
     WB=IPOPT(2+LB)
   ENDIF
   IF(WB.NE.0) THEN
!$OMP PARALLEL DO PRIVATE(N) SCHEDULE(STATIC)
     DO N=1,NO
       XPTB(N)=XPTS(N)+IB*RB2
       YPTB(N)=YPTS(N)+JB*RB2
     ENDDO
!$OMP END PARALLEL DO
     CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 1,NO,FILL,XPTB,YPTB,RLOB,RLAB,NV)
     CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI,-1,NO,FILL,XPTB,YPTB,RLOB,RLAB,NV)
     IF(IRET.EQ.0.AND.NV.EQ.0.AND.LB.EQ.0) IRET=2
!$OMP PARALLEL DO PRIVATE(N,XI,YI,I1,I2,J1,J2,XF,YF) SCHEDULE(STATIC)
     DO N=1,NO
       XI=XPTB(N)
       YI=YPTB(N)
       IF(XI.NE.FILL.AND.YI.NE.FILL) THEN
         I1=XI
         I2=I1+1
         J1=YI
         J2=J1+1
         XF=XI-I1
         YF=YI-J1
         N11(N)=IJKGDS1(I1,J1,IJKGDSA)
         N21(N)=IJKGDS1(I2,J1,IJKGDSA)
         N12(N)=IJKGDS1(I1,J2,IJKGDSA)
         N22(N)=IJKGDS1(I2,J2,IJKGDSA)
         IF(MIN(N11(N),N21(N),N12(N),N22(N)).GT.0) THEN
           W11(N)=(1-XF)*(1-YF)
           W21(N)=XF*(1-YF)
           W12(N)=(1-XF)*YF
           W22(N)=XF*YF
         ELSE
           N11(N)=0
           N21(N)=0
           N12(N)=0
           N22(N)=0
         ENDIF
       ELSE
         N11(N)=0
         N21(N)=0
         N12(N)=0
         N22(N)=0
       ENDIF
     ENDDO
!$OMP END PARALLEL DO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE WITH OR WITHOUT BITMAPS
!$OMP PARALLEL DO PRIVATE(K,N,GB) SCHEDULE(STATIC)
     DO K=1,KM
       DO N=1,NO
         IF(N11(N).GT.0) THEN
           IF(IBI(K).EQ.0) THEN
             GB=W11(N)*GI(N11(N),K)+W21(N)*GI(N21(N),K) &
                +W12(N)*GI(N12(N),K)+W22(N)*GI(N22(N),K)
             GO(N,K)=GO(N,K)+WB*GB
             WO(N,K)=WO(N,K)+WB
           ELSE
             IF(LI(N11(N),K)) THEN
               GO(N,K)=GO(N,K)+WB*W11(N)*GI(N11(N),K)
               WO(N,K)=WO(N,K)+WB*W11(N)
             ENDIF
             IF(LI(N21(N),K)) THEN
               GO(N,K)=GO(N,K)+WB*W21(N)*GI(N21(N),K)
               WO(N,K)=WO(N,K)+WB*W21(N)
             ENDIF
             IF(LI(N12(N),K)) THEN
               GO(N,K)=GO(N,K)+WB*W12(N)*GI(N12(N),K)
               WO(N,K)=WO(N,K)+WB*W12(N)
             ENDIF
             IF(LI(N22(N),K)) THEN
               GO(N,K)=GO(N,K)+WB*W22(N)*GI(N22(N),K)
               WO(N,K)=WO(N,K)+WB*W22(N)
             ENDIF
           ENDIF
         ENDIF
       ENDDO
     ENDDO
!$OMP END PARALLEL DO
   ENDIF
 ENDDO   ! sub-grid points
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE OUTPUT BITMAPS AND FIELDS
! KM is often 1 .. do not do OMP PARALLEL DO here
 KM_LOOP : DO K=1,KM
   IBO(K)=IBI(K)
!$OMP PARALLEL DO PRIVATE(N,LAT,LON,XXX,YYY,NV,XX,YY,IXS,JXS,MX,KXS,KXT,IX,JX,NX) SCHEDULE(STATIC)
   N_LOOP : DO N=1,NO
     LO(N,K)=WO(N,K).GE.PMP*NB4
     IF(LO(N,K)) THEN
       GO(N,K)=GO(N,K)/WO(N,K)
     ELSEIF (MSPIRAL.GT.1) THEN
       LAT(1)=RLAT(N)
       LON(1)=RLON(N)
       CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI,-1,1,FILL,XXX,YYY,LON,LAT,NV)
       XX=XXX(1)
       YY=YYY(1)
       IF(NV.EQ.1)THEN
         I1=NINT(XX)
         J1=NINT(YY)
         IXS=SIGN(1.,XX-I1)
         JXS=SIGN(1.,YY-J1)
         SPIRAL_LOOP : DO MX=2,MSPIRAL**2
           KXS=SQRT(4*MX-2.5)
           KXT=MX-(KXS**2/4+1)
           SELECT CASE(MOD(KXS,4))
           CASE(1)
             IX=I1-IXS*(KXS/4-KXT)
             JX=J1-JXS*KXS/4
           CASE(2)
             IX=I1+IXS*(1+KXS/4)
             JX=J1-JXS*(KXS/4-KXT)
           CASE(3)
             IX=I1+IXS*(1+KXS/4-KXT)
             JX=J1+JXS*(1+KXS/4)
           CASE DEFAULT
             IX=I1-IXS*KXS/4
             JX=J1+JXS*(KXS/4-KXT)
           END SELECT
           NX=IJKGDS1(IX,JX,IJKGDSA)
           IF(NX.GT.0.)THEN
             IF(LI(NX,K).OR.IBI(K).EQ.0) THEN
               GO(N,K)=GI(NX,K)
               LO(N,K)=.TRUE.
               CYCLE N_LOOP
             ENDIF
           ENDIF
         ENDDO SPIRAL_LOOP
         IBO(K)=1
         GO(N,K)=0.
       ELSE
         IBO(K)=1
         GO(N,K)=0.
       ENDIF
     ELSE  ! no spiral search option
       IBO(K)=1
       GO(N,K)=0.
     ENDIF
   ENDDO N_LOOP
!$OMP END PARALLEL DO
 ENDDO KM_LOOP
 IF(IGDTNUMO.EQ.0) CALL POLFIXS(NO,MO,KM,RLAT,IBO,LO,GO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATES3


program test
      real :: a
      a = 10.01
      print *, sqrt(a)
end program test


SUBROUTINE simlp(n, x, y, sad, alpha, beta, d, iter, inext, ifault)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-19  Time: 09:37:54

!     ALGORITHM AS 132  APPL. STATIST. (1978) VOL.27, NO.3

!     SIMLP:   Fit  Y = ALPHA + BETA.X + error

IMPLICIT NONE

INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN OUT)  :: x(n)
REAL, INTENT(IN)      :: y(n)
REAL, INTENT(OUT)     :: sad
REAL, INTENT(OUT)     :: alpha
REAL, INTENT(OUT)     :: beta
REAL, INTENT(OUT)     :: d(n)
INTEGER, INTENT(OUT)  :: iter
INTEGER, INTENT(OUT)  :: inext(n)
INTEGER, INTENT(OUT)  :: ifault

REAL, PARAMETER  :: acu = 1.0E-06, big = 1.0E19, half = 0.5, zero = 0.0,   &
                    one = 1.0, two = 2.0
INTEGER  :: i, ibas1, ibas2, iflag, iin, iout, isave, j
REAL     :: a1, a2, aaa, aaaa, ahalf, aone, bbb, bbbb, ddd, det,   &
            ratio, rho, subt, sum, t, test, tot1, tot2, y1, y2, zzz

!     Initial settings

ifault = 0
iter = 0
ahalf = half + acu
aone = ahalf + ahalf

!     Determine initial basis

d(1) = zero
y1 = y(1)
ibas1 = 1
a1 = x(1)
DO  i = 2, n
  IF (ABS(a1-x(i)) >= acu) THEN
    a2 = x(i)
    ibas2 = i
    y2 = y(i)
    GO TO 20
  END IF
END DO
ifault = 1
RETURN

!     Calculate initial beta value

20 det = one / (a2-a1)
aaaa = (a2*y1-a1*y2) * det
bbbb = (y2-y1) * det

!     Calculate initial D-vector

DO  i = 2, n
  ddd = y(i) - (aaaa+bbbb*x(i))
  d(i) = SIGN(one,ddd)
END DO
tot1 = one
tot2 = x(ibas2)
d(ibas2) = -one
DO  i = 2, n
  tot1 = tot1 + d(i)
  tot2 = tot2 + d(i) * x(i)
END DO
t = (a2*tot1-tot2) * det
IF (ABS(t) >= aone) THEN
  det = -det
  GO TO 70
END IF

!     Main iterative loop begins

50 t = (tot2-a1*tot1) * det
IF (ABS(t) < aone) GO TO 130
iflag = 2
iout = ibas2
x(iout) = a1
aaa = a1
bbb = a2
GO TO 80

60 t = (tot2-a2*tot1) * det
IF (ABS(t) < aone) GO TO 130

70 iflag = 1
bbb = a1
aaa = a2
iout = ibas1

80 rho = SIGN(one,t)
t = half * ABS(t)
det = det * rho

!     Perform partial sort of ratios

inext(ibas1) = ibas2
ratio = big
sum = ahalf
DO  i = 1, n
  ddd = (x(i)-aaa) * det
  IF (ddd*d(i) > acu) THEN
    test = (y(i)-aaaa-bbbb*x(i)) / ddd
    IF (test < ratio) THEN
      j = ibas1
      sum = sum + ABS(ddd)
      90 isave = ABS(inext(j))
      IF (test < d(isave)) THEN
        IF (sum >= t) THEN
          subt = ABS((x(isave)-aaa)*det)
          IF (sum-subt >= t) THEN
            sum = sum - subt
            d(isave) = SIGN(1,inext(j))
            inext(j) = inext(isave)
            GO TO 90
          END IF
        END IF
        100 j = isave
        isave = ABS(inext(j))
        IF (test < d(isave)) GO TO 100
      END IF
      inext(i) = inext(j)
      inext(j) = SIGN(i,INT(d(i)))
      d(i) = test
      IF (sum >= t) THEN
        iin = ABS(inext(ibas1))
        ratio = d(iin)
      END IF
    END IF
  END IF
END DO

!     Update basic indicators

iin = ABS(inext(ibas1))
j = iin
120 isave = ABS(inext(j))
IF (isave /= ibas2) THEN
  zzz = SIGN(1,inext(j))
  tot1 = tot1 - zzz - zzz
  tot2 = tot2 - two * zzz * x(isave)
  d(isave) = -zzz
  j = isave
  GO TO 120
END IF
zzz = SIGN(1,inext(ibas1))
tot1 = tot1 - rho - zzz
tot2 = tot2 - rho * bbb - zzz * x(iin)
d(iout) = -rho
iter = iter + 1
IF (iflag /= 1) THEN
  x(ibas2) = a2
  ibas2 = iin
  d(ibas2) = -one
  a2 = x(iin)
  y2 = y(iin)
  det = one / (a1-a2)
  aaaa = (a1*y2-a2*y1) * det
  bbbb = (y1-y2) * det
  GO TO 60
END IF
ibas1 = iin
a1 = x(iin)
d(ibas1) = zero
y1 = y(iin)
det = one / (a2-a1)
aaaa = (a2*y1-a1*y2) * det
bbbb = (y2-y1) * det
GO TO 50

!     Calculate optimal sum of absolute deviations

130 sad = zero
DO  i = 1, n
  d(i) = y(i) - (aaaa+bbbb*x(i))
  sad = sad + ABS(d(i))
END DO
alpha = aaaa
beta = bbbb

RETURN
END SUBROUTINE simlp


*DECK COST
      SUBROUTINE COST (N, X, WSAVE)
C***BEGIN PROLOGUE  COST
C***PURPOSE  Compute the cosine transform of a real, even sequence.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A3
C***TYPE      SINGLE PRECISION (COST-S)
C***KEYWORDS  COSINE FOURIER TRANSFORM, FFTPACK
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine COST computes the discrete Fourier cosine transform
C  of an even sequence X(I).  The transform is defined below at output
C  parameter X.
C
C  COST is the unnormalized inverse of itself since a call of COST
C  followed by another call of COST will multiply the input sequence
C  X by 2*(N-1).  The transform is defined below at output parameter X.
C
C  The array WSAVE which is used by subroutine COST must be
C  initialized by calling subroutine COSTI(N,WSAVE).
C
C  Input Parameters
C
C  N       the length of the sequence X.  N must be greater than 1.
C          The method is most efficient when N-1 is a product of
C          small primes.
C
C  X       an array which contains the sequence to be transformed
C
C  WSAVE   a work array which must be dimensioned at least 3*N+15
C          in the program that calls COST.  The WSAVE array must be
C          initialized by calling subroutine COSTI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.  Thus subsequent
C          transforms can be obtained faster than the first.
C
C  Output Parameters
C
C  X       For I=1,...,N
C
C             X(I) = X(1)+(-1)**(I-1)*X(N)
C
C               + the sum from K=2 to K=N-1
C
C                 2*X(K)*COS((K-1)*(I-1)*PI/(N-1))
C
C               A call of COST followed by another call of
C               COST will multiply the sequence X by 2*(N-1).
C               Hence COST is the unnormalized inverse
C               of itself.
C
C  WSAVE   contains initialization calculations which must not be
C          destroyed between calls of COST.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RFFTF
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*)
C   861211  REVISION DATE from Version 3.2
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  COST
      DIMENSION X(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  COST
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      IF (N-2) 106,101,102
  101 X1H = X(1)+X(2)
      X(2) = X(1)-X(2)
      X(1) = X1H
      RETURN
  102 IF (N .GT. 3) GO TO 103
      X1P3 = X(1)+X(3)
      TX2 = X(2)+X(2)
      X(2) = X(1)-X(3)
      X(1) = X1P3+TX2
      X(3) = X1P3-TX2
      RETURN
  103 C1 = X(1)-X(N)
      X(1) = X(1)+X(N)
      DO 104 K=2,NS2
         KC = NP1-K
         T1 = X(K)+X(KC)
         T2 = X(K)-X(KC)
         C1 = C1+WSAVE(KC)*T2
         T2 = WSAVE(K)*T2
         X(K) = T1-T2
         X(KC) = T1+T2
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1)
      CALL RFFTF (NM1,X,WSAVE(N+1))
      XIM2 = X(2)
      X(2) = C1
      DO 105 I=4,N,2
         XI = X(I)
         X(I) = X(I-2)-X(I-1)
         X(I-1) = XIM2
         XIM2 = XI
  105 CONTINUE
      IF (MODN .NE. 0) X(N) = XIM2
  106 RETURN
      END


    Program dopgtr_example

!     DOPGTR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_blas_damax_val, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dopgtr, dsptrd, dsteqr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: r
      Integer :: i, ifail, info, j, k, ldq, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ap(:), d(:), e(:), q(:, :), tau(:), &
        work(:)
!     .. Executable Statements ..
      Write (nout, *) 'DOPGTR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldq = n
      Allocate (ap(n*(n+1)/2), d(n), e(n), q(ldq,n), tau(n), work(2*n-2))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)((ap(i+j*(j-1)/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
      End If

!     Reduce A to tridiagonal form T = (Q**T)*A*Q
      Call dsptrd(uplo, n, ap, d, e, tau, info)

!     Form Q explicitly, storing the result in Q
      Call dopgtr(uplo, n, ap, tau, q, ldq, work, info)

!     Calculate all the eigenvalues and eigenvectors of A
      Call dsteqr('V', n, d, e, q, ldq, work, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) d(1:n)
        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors: largest element positive
        Do i = 1, n
          Call nagf_blas_damax_val(n, q(1,i), 1, k, r)
          If (q(k,i)<zero) Then
            q(1:n, i) = -q(1:n, i)
          End If
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, q, ldq, &
          'Eigenvectors', ifail)

      End If

100   Format (3X, (8F8.4))
    End Program


module Solver_mod
  use types_mod, only: DP, SI
  use rhs_mod, only: func

  implicit none

  private

  public :: fd1d_heat_explicit

contains

  subroutine fd1d_heat_explicit(x, dt, cfl, h, h_new)
    implicit none

    real (kind=DP), intent (in) :: cfl
    real (kind=DP), intent (in) :: dt
    ! real (kind=DP), intent (in) :: t
    real (kind=DP), dimension(:), intent (in)  :: h
    real (kind=DP), dimension(:), intent (in)  :: x
    real (kind=DP), dimension(:), intent (out) :: h_new

    integer(kind=SI) :: j
    real (kind=DP) :: f(size(x, 1))
    integer(kind=SI) :: xn

    xn = size(x, 1)

    do j = 1, xn
      f(j) = func()
    end do

    h_new(1) = 0.0e+00_DP

    do j = 2, xn - 1
      ! CamFort checks
      != stencil readOnce, (reflexive(dim=1)) :: f
      != stencil (centered(depth=1, dim=1)) :: h
      h_new(j) = h(j) + dt*f(j) + cfl*(h(j-1)-2.0e+00_DP*h(j)+h(j+1))
    end do

! set the boundary conditions again
    h_new(1) = 90.0e+00_DP
    h_new(xn) = 70.0e+00_DP
  end subroutine

end module Solver_mod


MODULE FUN_xyCOUNTERCLOCKWISE
!!#### PURPOSE
!! Determine the counter-clockwise ordering of a chain.

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

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_1_Rsp    => c_1 , & !!((02-A-PAR_Constants_Rsp.f90))
                     c_0_Rsp           => c_0 , &
                     c_PI_Rsp          => c_PI , &
                     c_sqrt_2_by_2_Rsp => c_sqrt_2_by_2
USE PAR_Constants_Rdp,ONLY: c_1_Rdp    => c_1 , & !!((02-A-PAR_Constants_Rdp.f90))
                     c_0_Rdp           => c_0 , &
                     c_PI_Rdp          => c_PI , &
                     c_sqrt_2_by_2_Rdp => c_sqrt_2_by_2

!!#### EXTERNAL PROCEDURES 1
USE FUN_xyANGLE    ,ONLY: xyANGLE_UU              !!((05-B-FUN_xyANGLE.f90))
USE FUN_xyDIRECTION,ONLY: xyDIRECTION_PP          !!((04-B-FUN_xyDIRECTION.f90))

!!#### EXTERNAL PROCEDURES 2
USE FUN_Reverse    ,ONLY: Reverse                 !!((04-A-FUN_Reverse.f90))
USE SUB_Sort_quick ,ONLY: Sort=>Sort_quick        !!((03-A-SUB_Sort_quick.f90))

!!#### GLOBAL USER MODULES
USE USR_Stack                                     !!((04-B-USR_Stack.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyCOUNTERCLOCKWISE_Cn
 MODULE PROCEDURE xyCOUNTERCLOCKWISE_Cn_Rsp
 MODULE PROCEDURE xyCOUNTERCLOCKWISE_Cn_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyCOUNTERCLOCKWISE_Cn

CONTAINS

PURE FUNCTION xyCOUNTERCLOCKWISE_Cn_Rsp( N , Cn , base , anchor , ReverseOrder ) RESULT(order_ccw)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp     !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1           = c_1_Rsp
REAL(KIND_R),PARAMETER :: c_0           = c_0_Rsp
REAL(KIND_R),PARAMETER :: c_PI          = c_PI_Rsp
REAL(KIND_R),PARAMETER :: c_sqrt_2_by_2 = c_sqrt_2_by_2_Rsp
INCLUDE "06-B-FUN_xyCOUNTERCLOCKWISE_Cn.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyCOUNTERCLOCKWISE_Cn.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyCOUNTERCLOCKWISE_Cn_Rdp( N , Cn , base , anchor , ReverseOrder ) RESULT(order_ccw)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp     !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1           = c_1_Rdp
REAL(KIND_R),PARAMETER :: c_0           = c_0_Rdp
REAL(KIND_R),PARAMETER :: c_PI          = c_PI_Rdp
REAL(KIND_R),PARAMETER :: c_sqrt_2_by_2 = c_sqrt_2_by_2_Rdp
INCLUDE "06-B-FUN_xyCOUNTERCLOCKWISE_Cn.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyCOUNTERCLOCKWISE_Cn.f90.bdy"
!!--end--
END FUNCTION

END MODULE


module newton

!> uses, basically we need something to tell us what precision is being used for calculations
use, intrinsic :: iso_fortran_env, only : stderr=>error_unit
use phys_consts, only: wp

implicit none (type, external)

!> derived type for containing the options for the newton method procedure, by default
!   these work okay with the dipole to spherical conversion problem but can be adjusted
!   by the user for other applications
type :: newtopts
  real(wp) :: derivtol=1e-18
  integer :: maxit=100
  real(wp) :: tol=1e-9
  logical :: verbose=.false.
end type newtopts

!> these interfaced define the types of functions needed to run Newton iterations
!   need to match custom functions defined in using modules; these are defined so
!   that there are multiple objective functions (conforming to these patterns) that
!   can be used with Newton's method.  These are abstract because there are multiple
!   objective functions (in principle) that can be used with Newton's method
abstract interface
  real(wp) function objfun(x,parms) result(fval)
    import wp
    real(wp), intent(in) :: x
    real(wp), dimension(:), intent(in) :: parms
  end function objfun
  real(wp) function objfun_deriv(x,parms) result(fval_deriv)
    import wp
    real(wp), intent(in) :: x
    real(wp), dimension(:), intent(in) :: parms
  end function objfun_deriv
end interface

contains

!> this implmements the exact Newton method for solving a nonlinear equation
subroutine newton_exact(f,fprime,x0,parms,newtparms,root,it,converged)
  procedure(objfun), pointer, intent(in) :: f
  procedure(objfun_deriv), pointer, intent(in) :: fprime
  real(wp), intent(in) :: x0                      ! starting point for newton iteration
  real(wp),dimension(:), intent(in) :: parms      ! fixed parameters of the newton iteration, f,fprime must accommodate whatever size array is passed in
  type(newtopts), intent(in) :: newtparms         ! options for the iteration that can be set by the user
  real(wp), intent(out) :: root
  integer, intent(out) :: it
  logical, intent(out) :: converged

  real(wp) :: fval,derivative

  ! check starting point is not too close to inflection
  if (abs(fprime(x0,parms))<newtparms%derivtol) then
    write(stderr,*) 'Warning:  starting near inflection point, please change initial guess!'
    it=0; converged=.false.; root=x0;
    return
  end if

  ! Newton iteration main loop
  it=1; root=x0; fval=f(root,parms); converged=.false.
  do while (.not. converged .and. it <= newtparms%maxit)
    derivative=fprime(root,parms)
    if (abs(derivative)<newtparms%derivtol) then
      write(stderr,*) 'Warning:  Encountered inflection point during iteration:  ',it
      return
    else
      root=root-fval/derivative
      fval=f(root,parms)
      if (newtparms%verbose) then
        print*, ' Iteration ',it,'; root ',root,' fval ',fval,' derivative ',derivative
      end if
      it=it+1
      converged=abs(fval)<newtparms%tol
    end if
  end do
  it=it-1

end subroutine newton_exact

end module newton


!> \file test_kzero.f90
!! \BRIEF Fortran 90 program to test kzero routine in gasx.f90
PROGRAM test_kzero

   USE msingledouble
   USE gasx

   IMPLICIT NONE

   INTEGER, PARAMETER :: n = 1

!  Computed variables:
   REAL(kind=r8), DIMENSION(1) :: k0_co2, k0_n2o

!  Input variables
   REAL(kind=rx), DIMENSION(1) :: temp, sal

!  Input at standard T and S
!  temp(1)   = 25.0
!  sal(1)    = 35.0

   temp(1)   = 4.0
   sal(1)    = 34.0

   call kzero('co2',   temp, sal, n, k0_co2)
   call kzero('n2o',   temp, sal, n, k0_n2o)

   write (*,*) "k0_co2   = ", k0_co2
   write (*,*) "k0_n2o   = ", k0_n2o

   write (*, *) ' '
   write (*,*) 'Results above should be 5.585e-2 and 4.132e-2 respectively:'
   write (*,*) '-> these values are the same as those in from Weiss (1974, Table 2) and'
   write (*,*) '   Weiss & Price (1980, Table 3), respectively, at T=4 and S=34'

   STOP
END PROGRAM test_kzero


!***********************************************************************
!                                                                      *
      SUBROUTINE FACTT
!                                                                      *
!   Calculates the logs  of factorials required by the Racah coeffi-   *
!   cient routine DRACAH.                                              *
!                                                                      *
!   Written by N S Scott                    Last update: 15 Oct 1992   *
!                                                                      *
!***********************************************************************
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:47:26   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE FACTS_C
      IMPLICIT NONE
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
      REAL(DOUBLE) :: X
!-----------------------------------------------
!
      GAM(1) = 1.0D00
      GAM(2) = 1.0D00
      X = 2.0D00
!
      DO I = 3, 30
         GAM(I) = GAM(I-1)*X
         X = X + 1.0D00
      END DO
!
      DO I = 1, 30
         GAM(I) = LOG(GAM(I))
      END DO
!
      X = 3.0D01
!
      DO I = 31, MFACT
         GAM(I) = GAM(I-1) + LOG(X)
         X = X + 1.0D00
      END DO
!
      RETURN
      END SUBROUTINE FACTT


!  pt_in_poly: point-in-polygon (tri/quad) test. For general polygon,
!              see pt_in_poly2.f90
!  signa
!====================================================================
!====================================================================

      subroutine pt_in_poly(i34,x,y,xp,yp,inside,arco,nodel)
!     (Single-precision) Routine to perform point-in-polygon
!     (triangle/quads) test and if it's inside, calculate the area coord.
!     (for quad, split it into 2 triangles and return the 3 nodes and
!     area coord.)
!     Inputs:
!            i34: 3 or 4 (type of elem)
!            x(i34),y(i34): coord. of polygon/elem. (counter-clockwise)
!            xp,yp: point to be tested
!     Outputs:
!            inside: 0, outside; 1, inside
!            arco(3), nodel(3) : area coord. and 3 local node indices (valid only if inside)
!      implicit real*8(a-h,o-z)
      integer, intent(in) :: i34
      real, intent(in) :: x(i34),y(i34),xp,yp
      integer, intent(out) :: inside,nodel(3)
      real, intent(out) :: arco(3)

      !Local
      integer :: list(3)
      real :: ar(2),swild(2,3)

      !Areas
      ar(1)=signa(x(1),x(2),x(3),y(1),y(2),y(3))
      ar(2)=0 !init
      if(i34==4) ar(2)=signa(x(1),x(3),x(4),y(1),y(3),y(4))
      if(ar(1)<=0.or.i34==4.and.ar(2)<=0) then
        print*, 'Negative area:',i34,ar,x,y
        stop
      endif

      inside=0
      do m=1,i34-2 !# of triangles
        if(m==1) then
          list(1:3)=(/1,2,3/) !local indices
        else !quads
          list(1:3)=(/1,3,4/)
        endif !m
        aa=0
        do j=1,3
          j1=j+1
          j2=j+2
          if(j1>3) j1=j1-3
          if(j2>3) j2=j2-3
          swild(m,j)=signa(x(list(j1)),x(list(j2)),xp,y(list(j1)),y(list(j2)),yp) !temporary storage
          aa=aa+abs(swild(m,j))
        enddo !j=1,3

        ae=abs(aa-ar(m))/ar(m)
        if(ae<=1.e-5) then
          inside=1
          nodel(1:3)=list(1:3)
          arco(1:3)=swild(m,1:3)/ar(m)
          arco(1)=max(0.,min(1.,arco(1)))
          arco(2)=max(0.,min(1.,arco(2)))
          if(arco(1)+arco(2)>1) then
            arco(3)=0
            arco(2)=1-arco(1)
          else
            arco(3)=1-arco(1)-arco(2)
          endif
          exit
        endif
      enddo !m

      end subroutine pt_in_poly

!====================================================================
      function signa(x1,x2,x3,y1,y2,y3)
!...  Compute signed area formed by pts 1,2,3

      signa=((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3))/2

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


PROGRAM test_complex
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
COMPLEX(KIND=DBL) :: c1 = (0.,0.)
REAL(KIND=DBL) :: a1 = 3.333333333333333_dbl
REAL(KIND=DBL) :: b1 = 6.666666666666666_dbl
c1 = CMPLX(a1,b1)
WRITE (*,*) c1
END PROGRAM test_complex


implicit none
integer :: i
open(unit=8,file=cosnumbers',status='replace')
open(unit=9,file=sinnumbers',status='replace')
do i=1,10
	write(8,*)	i,cos(dble(i))
	write(9,*)	i,sin(dble(i))
end do
close(8)
close(9)
stop
end

4670 Numerical Analysis/Class Examples/filez1.f90


program intrinsics_16
use iso_fortran_env, only: sp=>real32, dp=>real64
real(sp) :: r32
real(dp) :: r64
complex(sp) :: c32
complex(dp) :: c64
c32 = (5._sp, 7._sp); c64 = (5._dp, 7._dp)
r32 = aimag(c32)
r64 = aimag(c64)

end program


program problem70
  implicit none
  integer, parameter    :: m=664579,limit=10000000
  integer, dimension(m) :: primes
  integer               :: n,phi_n,answer
  real*8                :: n_over_phi_n,best

  open(33,file='./data/problem70.dat')
  read(33,*) primes

  best=huge(best)

  do n=2,limit
     phi_n=phi(n)
     if (predicate(n,phi_n)) then
        n_over_phi_n=real(n)/phi_n
        if (n_over_phi_n<best) then
           best=n_over_phi_n
           answer=n
        end if
     end if
  end do

  print *, answer, phi(answer), best

contains

  pure function predicate(x,y)
    implicit none
    integer, intent(in) :: x,y
    integer             :: a,b
    integer*16          :: temp1,temp2
    logical             :: predicate

    a=x
    b=y
    temp1=1
    temp2=1
    do while (a>0 .or. b>0)
       temp1=temp1*primes(mod(a,10)+1)
       temp2=temp2*primes(mod(b,10)+1)
       a=a/10
       b=b/10
    end do

    predicate=(temp1==temp2)

  end function predicate

  function phi(n)
    implicit none
    integer, intent(in) :: n
    integer             :: p,phi,i,rest
    logical             :: factor_found

    factor_found=.false.
    phi=n
    rest=n
    do i=1,n
       p=primes(i)
       if (mod(rest,p)==0) then
          phi=(phi/p)*(p-1)
          factor_found=.true.
          do while (mod(rest,p)==0)
             rest=rest/p
          end do
       end if

       ! Important: if the current prime is more than the square root
       ! of what is left, then what is left must be the last prime
       ! factor.
       if (p>sqrt(real(rest))) then
          if (rest>1) phi=(phi/rest)*(rest-1)
          exit
       end if
    end do

  end function phi

end program problem70