C
C-----------------------------------------------------------------------------
C
      double precision function alfa(alfa0,qsq )
C
C-----------------------------------------------------------------------------
C
C	This function returns the 1-loop value of alpha.
C
C	INPUT:
C		qsq   = Q^2
C
C-----------------------------------------------------------------------------
C
      implicit none
      double precision  qsq,alfa0
c
c constants
c
      double precision  One, Three, Pi,zmass
      parameter( One = 1.0d0, Three = 3.0d0 )
      parameter( Pi = 3.14159265358979323846d0 )
      parameter( zmass = 91.188d0 )
cc
      alfa = alfa0 / ( 1.0d0 - alfa0*dlog( qsq/zmass**2 ) /Three /Pi )
ccc
      return
      end

C
C-----------------------------------------------------------------------------
C
      double precision function alfaw(alfaw0,qsq,nh )
C
C-----------------------------------------------------------------------------
C
C	This function returns the 1-loop value of alpha_w.
C
C	INPUT:
C		qsq = Q^2
C               nh  = # of Higgs doublets
C
C-----------------------------------------------------------------------------
C
      implicit none
      double precision  qsq, alphaw, dum,alfaw0
      integer  nh, nq
c
c	  include
c

c
c constants
c
      double precision  Two, Four, Pi, Twpi, zmass,tmass
      parameter( Two = 2.0d0, Four = 4.0d0 )
      parameter( Pi = 3.14159265358979323846d0 )
      parameter( Twpi = 3.0d0*Four*Pi )
      parameter( zmass = 91.188d0,tmass=174d0 )
cc
      if ( qsq.ge.tmass**2 ) then
         nq = 6
      else
         nq = 5
      end if
      dum = ( 22.0d0 - Four*nq - nh/Two ) / Twpi
      alfaw = alfaw0 / ( 1.0d0 + dum*alfaw0*dlog( qsq/zmass**2 ) )
ccc
      return
      end

      DOUBLE PRECISION FUNCTION ALPHAS(Q)

      DOUBLE PRECISION Q,ALPHAS_not_timed
      external ALPHAS_not_timed

c     timing statistics
      include "timing_variables.inc"

c     This function takes roughly 0.6 micro-seconds and the function
c     cpu_time takes 0.3 so it does not make much sense to always leave
c     the timing profile. But it can be uncommented for dedicated study.
c      call cpu_time(tbefore)
      ALPHAS=ALPHAS_not_timed(Q)
c      call cpu_time(tAfter)

c      tPDF = tPDF + (tAfter-tBefore)
      RETURN
      end

C-----------------------------------------------------------------------------
C
      DOUBLE PRECISION FUNCTION ALPHAS_not_timed(Q)
c
c     Evaluation of strong coupling constant alpha_S
c     Author: R.K. Ellis
c
c     q -- scale at which alpha_s is to be evaluated
c
c-- common block alfas.inc
c     asmz -- value of alpha_s at the mass of the Z-boson
c     nloop -- the number of loops (1,2, or 3) at which beta
c
c     function is evaluated to determine running.
c     the values of the cmass and the bmass should be set
c     in common block qmass.
C-----------------------------------------------------------------------------

      IMPLICIT NONE
c
      include 'alfas.inc'
      DOUBLE PRECISION Q,T,AMZ0,AMB,AMC
      DOUBLE PRECISION AS_OUT
      INTEGER NLOOP0,NF3,NF4,NF5
      PARAMETER(NF5=5,NF4=4,NF3=3)
C
      REAL*8       CMASS,BMASS
      COMMON/QMASS/CMASS,BMASS
      DATA CMASS,BMASS/1.42D0,4.7D0/  ! HEAVY QUARK MASSES FOR THRESHOLDS
C
      REAL*8 ZMASS
      DATA ZMASS/91.188D0/
C
      SAVE AMZ0,NLOOP0,AMB,AMC
      DATA AMZ0,NLOOP0/0D0,0/
      IF (Q .LE. 0D0) THEN
         WRITE(6,*) 'q .le. 0 in alphas'
         WRITE(6,*) 'q= ',Q
         STOP
      ENDIF
      IF (asmz .LE. 0D0) THEN
         WRITE(6,*) 'asmz .le. 0 in alphas',asmz
c         WRITE(6,*) 'continue with asmz=0.1185'
         STOP
         asmz=0.1185D0
      ENDIF
      IF (CMASS .LE. 0.3D0) THEN
         WRITE(6,*) 'cmass .le. 0.3GeV in alphas',CMASS
c         WRITE(6,*) 'continue with cmass=1.5GeV?'
         STOP
         CMASS=1.42D0
      ENDIF
      IF (BMASS .LE. 0D0) THEN
         WRITE(6,*) 'bmass .le. 0 in alphas',BMASS
         WRITE(6,*) 'COMMON/QMASS/CMASS,BMASS'
         STOP
         BMASS=4.7D0
      ENDIF
c--- establish value of coupling at b- and c-mass and save
      IF ((asmz .NE. AMZ0) .OR. (NLOOP .NE. NLOOP0)) THEN
         AMZ0=asmz
         NLOOP0=NLOOP
         T=2D0*DLOG(BMASS/ZMASS)
         CALL NEWTON1(T,asmz,AMB,NLOOP,NF5)
         T=2D0*DLOG(CMASS/BMASS)
         CALL NEWTON1(T,AMB,AMC,NLOOP,NF4)
      ENDIF

c--- evaluate strong coupling at scale q
      IF (Q  .LT. BMASS) THEN
           IF (Q  .LT. CMASS) THEN
             T=2D0*DLOG(Q/CMASS)
             CALL NEWTON1(T,AMC,AS_OUT,NLOOP,NF3)
           ELSE
             T=2D0*DLOG(Q/BMASS)
             CALL NEWTON1(T,AMB,AS_OUT,NLOOP,NF4)
           ENDIF
      ELSE
      T=2D0*DLOG(Q/ZMASS)
      CALL NEWTON1(T,asmz,AS_OUT,NLOOP,NF5)
      ENDIF
      ALPHAS_not_timed=AS_OUT
      RETURN
      END

      SUBROUTINE NEWTON1(T,A_IN,A_OUT,NLOOP,NF)
C     Author: R.K. Ellis

c---  calculate a_out using nloop beta-function evolution
c---  with nf flavours, given starting value as-in
c---  given as_in and logarithmic separation between
c---  input scale and output scale t.
c---  Evolution is performed using Newton's method,
c---  with a precision given by tol.

      IMPLICIT NONE
      INTEGER NLOOP,NF
      REAL*8 T,A_IN,A_OUT,AS,TOL,F2,F3,F,FP,DELTA
      REAL*8 B0(3:5),C1(3:5),C2(3:5),DEL(3:5)
      PARAMETER(TOL=5.D-4)
C---     B0=(11.-2.*NF/3.)/4./PI
      DATA B0/0.716197243913527D0,0.66314559621623D0,0.61009394851893D0/
C---     C1=(102.D0-38.D0/3.D0*NF)/4.D0/PI/(11.D0-2.D0/3.D0*NF)
      DATA C1/.565884242104515D0,0.49019722472304D0,0.40134724779695D0/
C---     C2=(2857.D0/2.D0-5033*NF/18.D0+325*NF**2/54)
C---     /16.D0/PI**2/(11.D0-2.D0/3.D0*NF)
      DATA C2/0.453013579178645D0,0.30879037953664D0,0.14942733137107D0/
C---     DEL=SQRT(4*C2-C1**2)
      DATA DEL/1.22140465909230D0,0.99743079911360D0,0.66077962451190D0/
      F2(AS)=1D0/AS+C1(NF)*LOG((C1(NF)*AS)/(1D0+C1(NF)*AS))
      F3(AS)=1D0/AS+0.5D0*C1(NF)
     & *LOG((C2(NF)*AS**2)/(1D0+C1(NF)*AS+C2(NF)*AS**2))
     & -(C1(NF)**2-2D0*C2(NF))/DEL(NF)
     & *ATAN((2D0*C2(NF)*AS+C1(NF))/DEL(NF))

      A_OUT=A_IN/(1D0+A_IN*B0(NF)*T)
      IF (NLOOP .EQ. 1) RETURN
      A_OUT=A_IN/(1D0+B0(NF)*A_IN*T+C1(NF)*A_IN*LOG(1D0+A_IN*B0(NF)*T))
      IF (A_OUT .LT. 0D0) AS=0.3D0
 30   AS=A_OUT

      IF (NLOOP .EQ. 2) THEN
      F=B0(NF)*T+F2(A_IN)-F2(AS)
      FP=1D0/(AS**2*(1D0+C1(NF)*AS))
      ENDIF
      IF (NLOOP .EQ. 3) THEN
      F=B0(NF)*T+F3(A_IN)-F3(AS)
      FP=1D0/(AS**2*(1D0+C1(NF)*AS+C2(NF)*AS**2))
      ENDIF
      A_OUT=AS-F/FP
      DELTA=ABS(F/FP/AS)
      IF (DELTA .GT. TOL) GO TO 30
      RETURN
      END

C-----------------------------------------------------------------------------
C
      double precision function mfrun(mf,scale,asmz,nloop)
C
C-----------------------------------------------------------------------------
C
C	This function returns the 2-loop value of a MSbar fermion mass
C       at a given scale.
C
C	INPUT: mf    = MSbar mass of fermion at MSbar fermion mass scale
C	       scale = scale at which the running mass is evaluated
C	       asmz  = AS(MZ) : this is passed to alphas(scale,asmz,nloop)
C              nloop = # of loops in the evolution
C
C
C
C	EXTERNAL:      double precision alphas(scale,asmz,nloop)
C
C-----------------------------------------------------------------------------
C
      implicit none
C
C     ARGUMENTS
C
      double precision  mf,scale,asmz
      integer           nloop
C
C     LOCAL
C
      double precision  beta0, beta1,gamma0,gamma1
      double precision  A1,as,asmf,l2
      integer  nf
C
C     EXTERNAL
C
      double precision  alphas
      external          alphas
c
c     CONSTANTS
c
      double precision  One, Two, Three, Pi
      parameter( One = 1.0d0, Two = 2.0d0, Three = 3.0d0 )
      parameter( Pi = 3.14159265358979323846d0)
      double precision tmass
      parameter(tmass=174d0)
cc
C
C
      if ( mf.gt.tmass ) then
         nf = 6
      else
         nf = 5
      end if

      beta0 = ( 11.0d0 - Two/Three *nf )/4d0
      beta1 = ( 102d0  - 38d0/Three*nf )/16d0
      gamma0= 1d0
      gamma1= ( 202d0/3d0  - 20d0/9d0*nf )/16d0
      A1    = -beta1*gamma0/beta0**2+gamma1/beta0
      as    = alphas(scale)
      asmf  = alphas(mf)
      l2    = (1+ A1*as/Pi)/(1+ A1*asmf/Pi)

      mfrun = mf * (as/asmf)**(gamma0/beta0)

      if(nloop.eq.2) mfrun =mfrun*l2
ccc
      return
      end


MODULE m_keplerorb

! ----------------------------------------------------------------------
! MODULE: m_keplerorb.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the keplerorb subroutine used for computating Kepelrian orbit
!
! Subroutines contained within the module:
! - keplerorb
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	14 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE keplerorb (GM, MJDo, Sec0, Zo, Zel, Ndays, interv, orb1, orb2, found)

! ----------------------------------------------------------------------
! SUBROUTINE: keplerorb.f90
! ----------------------------------------------------------------------
! Purpose:
!  Kepler orbit based on the initial conditions as input
! ----------------------------------------------------------------------
! Input arguments:
! - GM:				Earth Gravity Constant (m^3/sec^2)
! - MJDo: 			Modified Julian Day number at the initial epoch (including the fraction of the day)
! - Sec0:			Seconds of Day at the initial epoch
! - Zo:				Initial state vector
! - Zel:			Coordinates type of the initial state vector
!   Zel = 1			Keplerian Elements
!   Zel = 2			State vector (Position & Velocity) cartesian coordinates in m & m/sec
! - Ndays:			Number of days of the keplerian orbit arc length to be computed
! - interv: 		Interval of the orbit epochs (in seconds)
!
! Output arguments:
! - orb1:			Orbit array of Keplerian elements per epoch
! - orb2: 			Orbit array of state vector's cartesian coordinates per epoch
! ----------------------------------------------------------------------
! Note 1:
! - kepler:		Kepler elements array (6)
!   a:       	semi-major axis  (m)
!   e:      	eccentricity
!   i:      	inclination (degrees)
!   Omega:  	right ascension of the ascending node (degrees)
!   omega:  	argument of perigee (degrees)
!   E:      	eccentric anomaly (degrees)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	25 August 2016
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 14 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 adavantages in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      !USE mdl_arr
	  !USE mdl_write
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: GM
      REAL (KIND = prec_q), INTENT(IN) :: MJDo, Sec0, Zo(6)
      INTEGER (KIND = prec_int4), INTENT(IN) :: Zel
      INTEGER (KIND = prec_int8), INTENT(IN) :: Ndays, interv
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: orb1
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: orb2
      LOGICAL, INTENT(OUT) :: found
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Norb, i, sz1, sz2
      REAL (KIND = prec_q) :: kepler_0(6), kepler_9(9), a_semiaxis, ec, Eo_rad, Mo_rad, n_motion
      REAL (KIND = prec_q) :: MJD_i, SecDay_i, SecDay_0, dt, Sec_arc
      REAL (KIND = prec_q) :: Mi_rad, Mi_deg, Ei
      REAL (KIND = prec_q) :: kepler_i(6), r_i(3), v_i(3)
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      CHARACTER (LEN=300) :: fname_write
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Gravitational constant
!GM = 0.39860044150D+15
! ----------------------------------------------------------------------

found = .true.

! Orbit arc in sec
Sec_arc = Ndays * 86400.D0

Norb = INT( Sec_arc / interv)

! orb1: Orbit array of Keplerian elements per epoch
ALLOCATE ( orb1(Norb, 8), STAT = AllocateStatus)

! orb2: Orbit array of state vector's cartesian coordinates per epoch
ALLOCATE ( orb2(Norb, 8), STAT = AllocateStatus)

! ----------------------------------------------------------------------
! Intial Conditions
If (Zel == 1) then

kepler_0 = Zo

Else if (Zel == 2) then

r_i = Zo(1:3)
v_i = Zo(4:6)
!CALL kepler_z2k (r_i, v_i, GM, kepler_0)
CALL kepler_z2k (r_i, v_i, GM, kepler_9)

End If

SecDay_0 = Sec0
!MJDo = MJDo

!a_semiaxis = kepler_0(1)
a_semiaxis = kepler_9(1)

!ec = kepler_0(2)
ec = kepler_9(2)

! Eccentric anomaly at to (radians)
!Eo_rad = kepler_0(7) * (PI_global / 180.D0)
Eo_rad = kepler_9(7) * (PI_global / 180.D0)

! Mean anomaly  at to (radians)
Mo_rad = Eo_rad - ec * sin(Eo_rad)
!Mo_rad = kepler_9(8) * (PI_global / 180.D0)

! ----------------------------------------------------------------------
! mean motion
n_motion = sqrt(GM / a_semiaxis**3)
! ----------------------------------------------------------------------

kepler_0(1:5) = kepler_9(1:5)
kepler_0(6) = kepler_9(7)

! ----------------------------------------------------------------------
! Computing Keplerian elements and State vector's cartesian coordinates per epoch
Do i = 1 , Norb

If (i == 1) then

! Initial Epoch
MJD_i    = MJDo
SecDay_i = SecDay_0

! Cartesian coordinates of the state vector (Inertial Frame)
kepler_i = kepler_0
CALL kepler_k2z (kepler_i, GM, r_i, v_i)

Else

! Epoch i
SecDay_i = SecDay_0 + interv * (i - 1)
!SecDay_i = SecDay_i + interv

!MJD_i = MJDo + SecDay_i / 86400.D0
MJD_i = INT(MJDo) + SecDay_i / 86400.D0

! ----------------------------------------------------------------------
! Time difference since initial epoch
dt = MJD_i - MJDo
dt = SecDay_i - SecDay_0
! ----------------------------------------------------------------------

! Mean anomaly at epoch i (radians)
Mi_rad = Mo_rad + n_motion * dt

! Mean anomaly in degrees
Mi_deg = Mi_rad * (180.D0/PI_global)

! Angle within the range {0 - 360}
If (Mi_deg >= 360.D0) then
	Mi_deg = Mi_deg - INT(Mi_deg / 360.D0) * 360.D0
End If

! Eccentric anomaly at ti (degrees) obtained by solving Kepler's Equation
CALL kepler_eq ( Mi_deg , ec , Ei)

!kepler_i = (/ a, e, i, Omega_asc, omega_per, Ei /)
kepler_i = (/ kepler_0(1), kepler_0(2), kepler_0(3), kepler_0(4), kepler_0(5), Ei /)

! Cartesian coordinates of the state vector (Inertial Frame)
CALL kepler_k2z (kepler_i, GM, r_i, v_i)

End If

! Orbit arrays
If (SecDay_i >= 86400.D0) Then
	SecDay_i = SecDay_i - INT(SecDay_i / 86400.D0) * 86400.D0
End If
orb1(i,:) = (/ MJD_i, SecDay_i, kepler_i /)
orb2(i,:) = (/ MJD_i, SecDay_i, r_i, v_i /)

End Do

End SUBROUTINE

END Module


	! integrates the frenkel-kontorova model by rk4 method

	implicit none

	integer, parameter :: nn=20,mm=nn/2,iter=1000
	double precision   :: xx(nn),yy(nn),dy(nn)
	double precision   :: tau,dtau
	integer            :: i,j,k,l,m,n
	double precision   :: Lam,KK,g0,g1,gam,pi

	common Lam,KK,g0,g1,gam

	open (unit=5,file='fre-kon.dat',status='unknown')

	Lam=1.0d0; KK=1.50d0
 	g0=10.0d0; g1=320.0d0; gam=40.0d0; pi=3.1416;

	tau=0.0d0; dtau=0.01d0

	yy(1)=pi+0.002d0
	yy(2)=pi+0.003d0
	yy(3)=pi+0.004d0
	yy(4)=pi+0.005d0
	yy(5)=pi+0.006d0
	yy(6)=pi+0.007d0
	yy(7)=pi+0.008d0
	yy(8)=pi+0.009d0
	yy(9)=pi+0.0023d0
	yy(10)=pi+0.0024d0

	yy(11)=0.001d0
	yy(12)=0.001d0
	yy(13)=0.001d0
	yy(14)=0.001d0
	yy(15)=0.001d0
	yy(16)=0.001d0
	yy(17)=0.001d0
	yy(18)=0.001d0
	yy(19)=0.001d0
	yy(20)=0.001d0

	do i=1,iter	! iterations

	call derivs(tau,yy,dy)
        call rk4(yy,dy,nn,tau,dtau,xx,derivs)
	yy=xx
	tau = tau + dtau
        write(5,'(1000(xf12.6))') (yy(l),l=1,nn)
	end do		! iterations

	end

	! calculates the time derivative

        subroutine derivs(tau,yy,dy)

        integer, parameter :: nn=20,mm=nn/2
	double precision   :: yy(nn),dy(nn)
	double precision   :: tau,dtau
	integer            :: i,j,k,l,m,n
        double precision   :: Lam,KK,g0,g1,gam

	common Lam,KK,g0,g1,gam

        do i=1,mm
	dy(i) = Lam*KK*yy(mm+i)
        end do

	dy(mm+1) = (Lam/KK)*(dsin(yy(mm)-yy(1))-dsin(yy(1)-yy(2)))
     .                 -(g0+g1*dcos(gam*tau))*dsin(yy(1))/Lam

	do i= 2,mm-1
	dy(mm+i) = (Lam/KK)*(dsin(yy(i-1)-yy(i))-dsin(yy(i)-yy(i+1)))
     .                 -(g0+g1*dcos(gam*tau))*dsin(yy(i))/Lam
	end do

	dy(nn) = (Lam/KK)*(dsin(yy(mm-1)-yy(mm))-dsin(yy(mm)-yy(1)))
     .                 -(g0+g1*dcos(gam*tau))*dsin(yy(mm))/Lam

        print *, 'The velocity on impact is', dy(nn)

        return
        end subroutine

	! performs the rk4 integration

	SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs)

	INTEGER n,NMAX
	REAL*8 h,x,dydx(n),y(n),yout(n)
	EXTERNAL derivs
	PARAMETER (NMAX=2000)
	INTEGER i
	REAL*8 h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX)

	hh=h*0.5
	h6=h/6.
	xh=x+hh

	do i=1,n
        yt(i)=y(i)+hh*dydx(i)
	end do

	call derivs(xh,yt,dyt)
	do i=1,n
        yt(i)=y(i)+hh*dyt(i)
	end do

	call derivs(xh,yt,dym)
	do i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
	end do

	call derivs(x+h,yt,dyt)
	do i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))
	end do

	return
	END


      SUBROUTINE QRITER (VAL,O,LOC,QR)
C
C     ORTEGA-KAISER QR ITERATION FOR A LARGE TRIDIAGONAL MATRIX
C
      INTEGER          LOC(1),QR,SYSBUF,MSG(10)
      REAL             LFREQ
      DOUBLE PRECISION VAL(1),O(1),SHIFT,ZERO,ONE,ONES,EPSI,G,R,S,T,U,
     1                 DLMDAS
      CHARACTER*5      BELOW,ABOVE,BELABV
      CHARACTER        UFM*23,UWM*25,UIM*29
      COMMON /XMSSG /  UFM,UWM,UIM
      COMMON /SYSTEM/  SYSBUF,NOUT
      COMMON /GIVN  /  IDUM0(100),N,LFREQ,IDUM3,IDUM4,HFREQ,LAMA,NV,
     1                 NE,IDUM9,NFOUND,IDUM11,IDUM12,IDUM13,NEVER,MAX
      COMMON /REIGKR/  IOPTN
      COMMON /MGIVXX/  DLMDAS
      DATA    EPSI  ,  ZERO,ONE,MSG/ 1.0D-10, 0.0D+0, 1.0D+0, 53,9*0 /
      DATA    MGIV  ,  BELOW,ABOVE / 4HMGIV, 'BELOW', 'ABOVE'        /
C
C     VAL    = DIAGONAL TERMS OF THE TRIDIAGONAL.
C              REORDERED EIGENVALUES UPON RETURN.
C     O      = SQUARE OF THE OFF-DIAGIONAL TERMS OF THE TRIDIAGONAL.
C     LOC    = ORIGINAL LOCATIONS OF THE REORDERED EIGENVALUES.
C     QR     = 1 MEANS  VAL= EIGENVALUES--JUST REORDER THEM
C     N      = ORDER OF THE PROBLEM = ALSO NO. OF FREQ. EXTRACTED
C     MAX    = MAXIMUM NUMBER OF ITERATIONS
C     SHIFT  = SHIFT FACTOR (SMALLEST DIAGONAL TERM
C     LFREQ  , HFREQ = FREQ. RANGE OF INTEREST IF NV IS ZERO
C     NV     = NUMBER OF EIGENVECTORS TO BE COMPUTED, SAVED AND OUTPUT.
C              IF NV IS ZERO (INPUT), AND LFREQ-HFREQ ARE PRESENT, NV IS
C              SET TO BE NO. OF MODES WITHIN THE FREQ. RANGE (OUTPUT)
C     NE     = NO. OF EIGENVALUES (INCLUDING RIGID MODES) TO BE PRINTED.
C              ALL, IF NE IS NOT SPECIFIED.
C              IF NE .LT. NV, NE IS SET EQUAL TO NV
C
      MAX = 100*N
      IF (NV .GT.  N) NV = N
      IF (NE .EQ.  0) NE = N
      IF (NE .LT. NV) NE = NV
C
C     IS THIS AN ORDERING ONLY CALL
C
      NEVER = 0
      IF (QR .NE. 0) GO TO 150
C
C     SEARCH FOR A DECOUPLED SUBMATRIX.
C
      M2 = N
  100 M2M1 = M2 - 1
      DO 101 K = 1,M2M1
      M1 = M2 - K
      IF (O(M1) .NE. ZERO) GO TO 102
  101 CONTINUE
C
C     ALL OFF-DIAGONAL TERMS ARE ZEROS, JOB DONE. GO TO 150
C     THE DIAGONALS CONTAIN THE EIGENVALUES.
C
      GO TO 150
C
C     DECOUPLED SUBMATRIX
C
  102 M2M1 = M1
      M2   = M1 + 1
      IF (M2M1 .EQ. 1) GO TO 105
      DO 103 K = 2,M2M1
      M1 = M2 - K
      IF (O(M1) .EQ. ZERO) GO TO 104
  103 CONTINUE
      GO TO 105
  104 M1 = M1 + 1
  105 MM = M1
C
C     Q-R ITERATION FOR THE DECOUPLED SUBMATRIX
C
  110 DO 135 ITER = 1,MAX
      IF (DABS(VAL(M2))+O(M2M1) .EQ. DABS(VAL(M2))) GO TO 140
      DO 111 K = M1,M2M1
      IF (VAL(K) .NE. VAL(K+1)) GO TO 115
  111 CONTINUE
      SHIFT = ZERO
      GO TO 120
C
C     FIND THE SMALLEST DIAGONAL TERM = SHIFT
C
  115 SHIFT = VAL(M2)
      DO 116 I = M1,M2M1
      IF (DABS(VAL(I)) .LT. DABS(SHIFT)) SHIFT = VAL(I)
  116 CONTINUE
C
C     REDUCE ALL TERMS BY SHIFT
C
      DO 117  I = M1,M2
      VAL(I) = VAL(I) - SHIFT
  117 CONTINUE
C
C     Q-R ITERATION
C
  120 R = VAL(M1)**2
      S = O(M1)/(R+O(M1))
      T = ZERO
      U = S*(VAL(M1) + VAL(M1+1))
      VAL(M1) = VAL(M1) + U
      IF (M1 .EQ. M2M1) GO TO 125
      M1P1 = M1 + 1
      DO 123 I = M1P1,M2M1
      G = VAL(I) - U
      R = (ONE-T)*O(I-1)
      ONES = ONE - S
      IF (DABS(ONES) .GT. EPSI) R = G*G/ONES
      R = R + O(I)
      O(I-1) = S*R
      IF (O(I-1) .EQ. ZERO) MM = I
      T = S
C
C     IBM MAY FLAG AN EXPONENT UNDERFLOW ON NEXT LINE.
C     IT IS PERFECTLY OK SINCE O(I) SHOULD BE APPROACHING ZERO.
C
      S = O(I)/R
      U = S*(G + VAL(I+1))
      VAL(I) = U + G
  123 CONTINUE
C
  125 VAL(M2) = VAL(M2) - U
      R = (ONE-T)*O(M2M1)
      ONES = ONE - S
      IF (DABS(ONES) .GT. EPSI) R = VAL(M2)**2/ONES
      O(M2M1) = S*R
C
C     SHIFT BACK
C
      IF (SHIFT .EQ. ZERO) GO TO 133
      DO 130 I = M1,M2
      VAL(I) = VAL(I) + SHIFT
  130 CONTINUE
  133 M1 = MM
  135 CONTINUE
C
C     TOO MANY ITERATIONS
C
C
C     THE ACCURACY OF EIGENVALUE  XXXXX  IS IN DOUBT--QRITER FAILED TO
C     CONVERGE IN  XX  ITERATIONS
C
      NEVER = NEVER + 1
      CALL MESAGE (MSG(1),VAL(M2),MAX)
C
C     CONVERGENCE ACHIEVED
C
  140 IF (M1 .EQ. M2M1) GO TO 145
      M2   = M2M1
      M2M1 = M2 -1
      GO TO 110
  145 IF (M1 .LE. 2) GO TO 150
      M2 = M1 - 1
      GO TO 100
  150 IF (N .EQ. 1) GO TO 205
C
C     REORDER EIGENVALUES ALGEBRAICALLY IN ASCENDING ORDER
C
      IF (IOPTN .NE. MGIV) GO TO 155
C
C     FOR MGIV METHOD, RECOMPUTE LAMBDA
C
      DO 153 K = 1,N
      VAL(K) = (1.0D0/VAL(K)) - DLMDAS
  153 CONTINUE
  155 CONTINUE
      DO 190 K = 1,N
      DO 160 M = 1,N
      IF (VAL(M) .NE. -10000.0D0) GO TO 170
  160 CONTINUE
  170 IF (M .EQ. N) GO TO 185
      MP1 = M + 1
      DO 180 I = MP1,N
      IF (VAL(I) .EQ. -10000.0D0) GO TO 180
      IF (VAL(M) .GT. VAL(I)) M = I
  180 CONTINUE
  185 O(K)   = VAL(M)
      VAL(M) =-10000.0D0
      LOC(K) = M
  190 CONTINUE
      DO 195 I = 1,N
      VAL(I) = O(I)
  195 CONTINUE
C
C     IF RIGID MODES WERE FOUND BEFORE, REPLACE RIGID FREQ. BY ZERO
C
      IF (NFOUND .EQ. 0) GO TO 205
      DO 200 I = 1,NFOUND
      VAL(I) = ZERO
  200 CONTINUE
C
C     OUTPUT OPTION CHECK - BY FREQ. RANGE OR BY NO. OF FREQ.
C     REQUESTED
C
  205 IB    = 1
      IF (NV .NE. 0) GO TO 225
      IF (LFREQ .LE. 0.0) GO TO 225
C
C     LOCATE PONTER THAT POINTS TO EIGENVALUE ABOVE OR EQUAL THE
C     LOWEST LFREQ. AS REQUESTED.
C
      DO 215 I = 1,N
      IF (VAL(I) .GE. LFREQ) GO TO 220
  215 CONTINUE
      I  = 0
  220 IB = I
C
C     OPEN LAMA FOR OUTPUT
C     PUT EIGENVALUES ON LAMA FOLLOWED BY ORDER FOUND
C
  225 IBUF1 = (KORSZ(O)-SYSBUF+1)/2
      CALL GOPEN (LAMA,O(IBUF1),1)
      NN = 0
      IF (IB .EQ. 0) GO TO 240
      DO 230 I = IB,N
      VALX = VAL(I)
      IF (NV.NE.0 .AND.    I.GT.   NE) GO TO 240
      IF (NV.EQ.0 .AND. VALX.GT.HFREQ) GO TO 240
      CALL WRITE (LAMA,VALX,1,0)
      NN = NN + 1
  230 CONTINUE
C
  240 CONTINUE
C
C     IF FREQ. RANGE IS REQUESTED, AND ALL FREQ. FOUND ARE OUTSIDE THE
C     RANGE, OUTPUT AT LEAST ONE FREQ.
C
      IF (NN .GT. 0) GO TO 260
      IF (IB .EQ. 0) BELABV = BELOW
      IF (IB .NE. 0) BELABV = ABOVE
      WRITE (NOUT,250) UIM,BELABV
  250 FORMAT (A29,', ALL ROOTS FOUND WERE ',A5,' FREQ. RANGE SPECIFIED',
     1       /5X,'HOWEVER, ONE EIGENVALUE OUTSIDE THIS FREQ. RANGE WAS',
     2       ' SAVED AND PRINTED')
      NN = 1
      IF (IB .NE. 0) IB = N
      IF (IB .EQ. 0) IB = 1
      CALL WRITE (LAMA,VAL(IB),1,0)
  260 CALL WRITE (LAMA,0,0,1)
      CALL WRITE (LAMA,LOC(IB),NN,1)
      CALL CLOSE (LAMA,1)
      MSG(2) = LAMA
      MSG(3) = NN
      CALL WRTTRL (MSG(2))
C
C     IF FREQ. DOES NOT START FROM FIRST FUNDAMENTAL MODE, ADJUST VAL
C     AND LOC TABLES SO THAT WILVEC WILL PICK UP FREQUENCIES CORRECTLY
C
      IF (IB .LE. 1) GO TO 280
      J = 1
      DO 270 I = IB,N
      VAL(J) = VAL(I)
      LOC(J) = LOC(I)
  270 J = J + 1
C
  280 IF (NV.EQ.0 .AND. IB.GT.1 .AND. NN.LT.NFOUND .AND. VAL(1).LE.ZERO)
     1    NFOUND = 0
      IF (NV .EQ. 0) NV = NN
      RETURN
      END


module user_defined_functions
  use num_integration
  use utils, only : wp
  implicit none

  abstract interface
    function f_interface(x)
      import :: wp
      real(wp), intent(in) :: x
      real(wp) :: f_interface
    end function f_interface

    function linear_spline_interface(y,x)
      import :: wp
      real(wp), intent(in) :: y(3),x
      real(wp) :: linear_spline_interface
    end function linear_spline_interface

    function cubic_spline_interface(y,x)
      import :: wp
      real(wp), intent(in) :: y(5),x
      real(wp) :: cubic_spline_interface
    end function cubic_spline_interface
  end interface

  type, extends(fun) :: inner_product_l_obj
    ! Support nodes for base i and base j of the spline
    real(wp), allocatable :: yi(:), yj(:)

    ! Pointers to f, q and k function, as described by
    ! the formula.
    procedure(f_interface), pointer, nopass :: k,q

    ! Pointers to linear_spline functions
    procedure(linear_spline_interface), pointer, nopass :: l,dl

    ! Pointers to cubic_spline functions
    procedure(cubic_spline_interface), pointer, nopass :: c,dc

    ! Only cubic or linear splines pointers will be
    ! assigned, depending on the size of the y array.

  contains
    procedure :: eval => inner_product_l_eval
  end type inner_product_l_obj

  type, extends(fun) :: inner_product_obj
    ! Support nodes for base i and base j of the spline
    real(wp), allocatable :: y(:)

    procedure(f_interface), pointer, nopass :: f

    ! Pointers to linear_spline functions
    procedure(linear_spline_interface), pointer, nopass :: l

    ! Pointers to cubic_spline functions
    procedure(cubic_spline_interface), pointer, nopass :: c

    ! Only cubic or linear splines pointers will be
    ! assigned, depending on the size of the y array.

  contains
    procedure :: eval => inner_product_eval
  end type inner_product_obj

contains
  function inner_product_l_eval(self, x)
    class(inner_product_l_obj), intent(in) :: self
    real(wp), intent(in) :: x
    real(wp) :: inner_product_l_eval

    if ( size(self%yi) == 3 ) then
      ! Inner product for linear_splines
      inner_product_l_eval = &
      self%k(x) * self%dl(self%yi,x) * self%dl(self%yj,x) &
      + self%q(x) * self%l(self%yi,x) * self%l(self%yj,x)

    elseif ( size(self%yi) == 5 ) then
      ! Inner product for cubic_splines
      inner_product_l_eval =  &
      self%k(x) * self%dc(self%yi,x) * self%dc(self%yj,x) &
      + self%q(x) * self%c(self%yi,x) * self%c(self%yj,x)

    else
      ! Something went wrong
      write(*,*) "Incorrect usage."
      inner_product_l_eval = 0.0_wp
    end if
  end function inner_product_l_eval

  function inner_product_eval(self, x)
    class(inner_product_obj), intent(in) :: self
    real(wp), intent(in) :: x
    real(wp) :: inner_product_eval

    if ( size(self%y) == 3 ) then
      ! Inner product for linear_splines
      inner_product_eval = &
      self%f(x) * self%l(self%y,x)

    elseif ( size(self%y) == 5 ) then
      ! Inner product for cubic_splines
      inner_product_eval =  &
      self%f(x) * self%c(self%y,x)
    else
      ! Something went wrong
      write(*,*) "Incorrect usage."
      inner_product_eval = 0.0_wp
    end if
  end function inner_product_eval

  subroutine set_inner_product_l(ipo,yi,yj,k,q,phi,dphi)
    class(inner_product_l_obj), intent(inout) :: ipo
    real(wp), external :: q,k,f,phi,dphi
    real(wp), intent(in) :: yi(:),yj(:)
!    allocate(ipo%yi(size(yi)))
!    allocate(ipo%yj(size(yj)))
    ipo%yi = yi
    ipo%yj = yj
    ipo%k => k
    ipo%q => q
    if ( size(yi) == 3 ) then
      ! Pointers to linear_spline functions
      ipo%l => phi
      ipo%dl => dphi
    elseif ( size(yi) == 5 ) then
      ! Pointers to cubic_spline functions
      ipo%c => phi
      ipo%dc => dphi
    end if
  end subroutine set_inner_product_l

  subroutine set_inner_product(ipo,y,f,phi)
    class(inner_product_obj), intent(inout) :: ipo
    real(wp), external :: f,phi
    real(wp), intent(in) :: y(:)
    ipo%y = y
    ipo%f => f
    if ( size(y) == 3 ) then
      ! Pointers to linear_spline functions
      ipo%l => phi
    elseif ( size(y) == 5 ) then
      ! Pointers to cubic_spline functions
      ipo%c => phi
    end if
  end subroutine set_inner_product

  function estimated_function(alpha,x,support_nodes,spline_base)
    real(wp), external :: spline_base
    real(wp), intent(in) :: alpha(:),support_nodes(:,:)
    real(wp), intent(in) :: x
    real(wp) :: estimated_function
    integer :: i
    estimated_function = 0
    do i = 1, size(alpha)
      estimated_function = estimated_function + alpha(i)*spline_base(support_nodes(i,1:),x)
    end do
  end function estimated_function

end module user_defined_functions

program main
use utils
!use bm_ge
use g_elimination
use num_integration
use bspline
use user_defined_functions
use ogpf

implicit none

!---------------
! Variables
!---------------

integer :: i,j,romberg_iterations
integer, allocatable :: n(:)
real(wp) :: x,error
real(wp), allocatable :: error_array_linear(:),error_array_cubic(:)
type(gpf):: gp

!---------------
! Logic
!---------------

write(*,*) "Program started!"

! Array of number of internal nodes for the integration
allocate(n(7))

! Array for plotting errors
allocate(error_array_linear(7))
allocate(error_array_cubic(7))

! Number of internal nodes for the integration
n(1:) = [7, 15, 31, 63, 127, 255, 511]

romberg_iterations = 7
! ---------------------------
! Solving with linear splines
! ---------------------------
do i = 1, 1
!  call solve_finite_elements(n(i),linear_spline,linear_spline_deriv,.false.,romberg_iterations,error)
!  error_array_linear(i) = error
end do

!call gp%plot(linspace(1.0_wp,4.0_wp,4),error_array_linear(1:4))

! ---------------------------
! Solving with cubic splines
! ---------------------------
do i = 1, 2
  call solve_finite_elements(n(i),cubic_spline,cubic_spline_deriv,.true.,romberg_iterations,error)
  error_array_cubic(i) = error
end do

!call gp%plot(linspace(1.0_wp,4.0_wp,4), error_array_cubic(1:4))

contains

! User defined functions for the problem
! to be solved go here

  function k(x)
    real(wp), intent(in) :: x
    real(wp) :: k
    k = 1
  end function k

  function q(x)
    real(wp), intent(in) :: x
    real(wp) :: q
    q = 0
  end function q

  function f(x)
    real(wp), intent(in) :: x
    real(wp) :: f
    f = (pi**2)*(sin(pi*x)-9*sin(3*pi*x))
  end function f

  function u(x)
    real(wp), intent(in) :: x
    real(wp) :: u
    u = sin(pi*x) - sin(3*pi*x)
  end function u

  subroutine solve_finite_elements(n,base_spline,base_spline_deriv,type,romberg_iterations,error)
    integer, intent(in) :: n,romberg_iterations
    real(wp), intent(inout) :: error
    real(wp), external :: base_spline,base_spline_deriv
    ! Flag:
    ! If .true. cubic, if .false. linear
    logical, intent(in) :: type
    integer :: i,j,l,o,m,ub,lb,ms,lini,lend,c
    integer :: num_basis,total_num_nodes,num_nodes_ep,num_support_nodes,total_num_support_nodes
    real(wp), parameter :: alpha = 0.0_wp
    real(wp), parameter :: omega = 1.0_wp
    real(wp) :: a,b,h,x,result
    real(wp), allocatable :: integration_range(:),support_node_i(:)&
                              ,support_node_j(:), f_phi(:), coef(:)&
                              ,support_nodes_array(:,:), plot_expected(:)&
                              ,plot_calculated(:)
    type(inner_product_l_obj) :: ipol
    type(inner_product_obj) :: ipo
    type(col), allocatable :: Row(:)
    type(gpf):: gp

    write(*,*) "-------------------------"
    write(*,*) "Number of internal nodes:"
    write(*,*) n
    write(*,*)
    write(*,*) "Solving with:"

    ! Number of upper and lower bands
    ! ub = lb = 1 iff linear splines
    ! ub = lb = 3 iff cubic splines
    ! Number of support nodes
    ! 3 = Linear Spline
    ! 5 = Cubic Spline
    if ( type ) then
      write(*,*) "Cubic Splines"
      write(*,*)
      ub = 3
      lb = 3
      ! Number of internal nodes
      num_support_nodes = 3
      ! Total number of nodes
      total_num_support_nodes = num_support_nodes+2
    else
      write(*,*) "Linear Splines"
      write(*,*)
      ub = 1
      lb = 1
      ! Number of internal nodes
      num_support_nodes = 1
      ! Total number of nodes
      total_num_support_nodes = num_support_nodes+2
    end if

    ! Total number of integration nodes
    ! total_num_nodes = internal nodes + 2
    total_num_nodes = n+2

    ! Saving results for plots
    allocate(plot_expected(total_num_nodes))
    allocate(plot_calculated(total_num_nodes))

    ! Number of b-spline basis
    num_basis = total_num_nodes+(num_support_nodes-1)

    ! Extended partition
    num_nodes_ep = total_num_nodes+2*num_support_nodes

    ! Banded matrix structure
    allocate(Row(num_basis))

    ! Array for the result of the
    ! inner product between f and the splines
    allocate(f_phi(num_basis))

    ! Coefficients alpha
    allocate(coef(num_basis))

    ! Stepsize
    h = 1.0_wp/(n+1.0_wp)
    write(*,*) "Step size"
    write(*,*) h
    write(*,*)

    ! Nodes in the integration range
    allocate(integration_range(num_nodes_ep))

    do i = 1, num_nodes_ep
      integration_range(i) = (i-total_num_support_nodes+1)*h
    end do

    ! Support nodes for the splines
    allocate(support_node_i(total_num_support_nodes))
    allocate(support_node_j(total_num_support_nodes))
    allocate(support_nodes_array(num_basis,total_num_support_nodes))

    write(*,*) "Creating banded matrix"
    write(*,*) ". . ."
    do m = 1,num_basis
      ! Construct support nodes for the spline i
      do i = 1,total_num_support_nodes
        support_node_i(i) = integration_range(m) + (i-1)*h
      end do

      ! Save this support node array for later use
      ! at the `estimated_function` method
      support_nodes_array(m,1:) = support_node_i(1:)

      call set_inner_product(ipo,support_node_i,&
                            f,&
                            base_spline&
                            )

      a = max(support_node_i(1),0.0_wp)
      b = min(support_node_i(size(support_node_i)),1.0_wp)
      f_phi(m) = romberg(ipo, a, b, romberg_iterations)

      ! Calculating how many support nodes
      ! phi_j shall be used in the L inner
      ! product agains phi_i
      lini = -num_support_nodes
      lend = num_support_nodes
      if ( m < lb+1 ) then
        lini = 0+(1-m)
        lend = num_support_nodes
      elseif ( m > num_basis-ub ) then
        lini = -num_support_nodes
        lend = num_support_nodes-(ub+m-num_basis)
      end if
      allocate(Row(m)%col(2*(num_support_nodes)+1-(abs(lini+lend))))

      ! Variable o helps with indexing
      o = 1
      do j = lini,lend
        ! Set support node values for the spline j
        do i = 1,total_num_support_nodes
          support_node_j(i) = integration_range(m+j) + (i-1)*h
        end do

        ! Test
        !write(*,*) support_node_i
        !write(*,*) support_node_j
        !write(*,*)

        ! Set values the inner product,
        ! according to the given formula
        call set_inner_product_l(ipol,support_node_i,support_node_j,&
                            k,q,&
                            base_spline,base_spline_deriv&
                            )

        ! Define integration limits
        a = min(support_node_i(1), support_node_j(1))
        b = max(support_node_i(total_num_support_nodes),&
                support_node_j(total_num_support_nodes))

        ! Integrate inner product using Romberg's
        ! Save result in the banded matrix structure
        Row(m)%col(o) = romberg(ipol, a, b, romberg_iterations)

        o = o + 1
      end do
    end do
    write(*,*) "Banded matrix creation complete"
    write(*,*)

    ! Test
    call pprint_band(Row,lb,ub)
    write(*,*)
    write(*,'(F10.5)') coef
    write(*,*)
    write(*,'(F10.5)') f_phi
    write(*,*)

    write(*,*) "Performing gaussian elimination"
    write(*,*) ". . ."
    call gaussian_elimination_banded(Row,coef,f_phi,lb,ub)
    write(*,*) "Gaussian elimination complete"
    write(*,*)

    ! Test
    call pprint_band(Row,lb,ub)
    write(*,*)
    write(*,'(F10.5)') coef
    write(*,*)
    write(*,'(F10.5)') f_phi
    write(*,*)

    write(*,*) "Calculating Error`s Infinity Norm"
    write(*,*) ". . ."

    error = 0.0_wp
    do i = 1, total_num_nodes

      x = integration_range(i+num_support_nodes)
      ! Test
      !write(*,*) x
      plot_expected(i) = u(x)

      plot_calculated(i) = estimated_function(coef,x,support_nodes_array,base_spline)

      if ( abs(plot_calculated(i)-plot_expected(i)) > error ) then
        error = abs(plot_calculated(i)-plot_expected(i))
      end if

    end do
    write(*,*) "Error: ",error
    write(*,*)

    write(*,*) "Now plotting"
    write(*,*) ". . ."
    if ( type ) then
      call gp%title('Cubic Spline')
    else
      call gp%title('Linear Spline')
    end if
    call gp%options('set key top right; set grid')
    call gp%plot(x1=integration_range(1+num_support_nodes:num_nodes_ep-num_support_nodes),&
            y1=plot_expected,&
            ls1='title "Expected" with lines lt 1 lw 1',&
            x2=integration_range(1+num_support_nodes:num_nodes_ep-num_support_nodes),&
            y2=plot_calculated,&
            ls2='title "Calculated" with lines lt 2 lw 1')

    write(*,*) "Plotting done"
    write(*,*)
    write(*,*) "Problem solved"
    write(*,*) "---------------"
    write(*,*)
  end subroutine solve_finite_elements
end program main


c---------------------------------------------------------------------
c---------------------------------------------------------------------
      subroutine l2norm (v, sum, nx, nxmax, ny, nz)
c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   to compute the l2-norm of vector v.
c---------------------------------------------------------------------

      implicit none

c---------------------------------------------------------------------
c  input parameters
c---------------------------------------------------------------------
      integer nx, nxmax, ny, nz
      double precision  v(5,nxmax,ny,nz), sum(5)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m
      double precision  sum_cap(5)

      do m = 1, 5
         sum(m) = 0.0d+00
      end do

!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(sum_cap,m,i,j,k)
!$OMP&  SHARED(nx,ny,nz)
      do m=1,5
         sum_cap(m)=0.0d0
      enddo
      do k = 2, nz-1
!$OMP DO SCHEDULE(STATIC)
         do j = 2, ny-1
            do i = 2, nx-1
               do m = 1, 5
                  sum_cap(m) = sum_cap(m) + v(m,i,j,k) * v(m,i,j,k)
               end do
            end do
         end do
!$OMP END DO nowait
      end do
      do m=1,5
!$OMP ATOMIC
         sum(m)=sum(m)+sum_cap(m)
      enddo
!$OMP END PARALLEL

      do m = 1, 5
         sum(m) = dsqrt(sum(m) / (dble(nz-2)*dble(ny-2)*dble(nx-2)))
      end do

      return
      end


module functions
  implicit none
contains

function binsearch(n,a)
  implicit none
  integer(2) :: binsearch,left,right,mid
  integer(8) :: n,a(:)

  left=1
  right=size(a)
  if ( n >= a(right) ) then
    binsearch=right
    return
  end if
  do while ( .true. )
    mid=(left+right)/2
    if ( left == mid .or. n == a(mid) ) exit
    if ( n > a(mid) ) then
      left=mid
    else
      right=mid
    end if
  end do
  binsearch=mid
  return
end function binsearch

function nchoosek(n,k)
  implicit none
  integer(2) :: k,n,i,ia,ib
  integer(8) :: nchoosek
  real(8) :: A,B

  if ( k < n-k ) then
    ia=n-k+1
    ib=k
  else
    ia=k+1
    ib=n-k
  end if
  A=1;B=1
  do i=ia,n
    A=A*i
  end do
  do i=2,ib
    B=B*i
  end do
  nchoosek=A/B+0.5
  return
end function nchoosek

function complement(a,m)
  implicit none
  integer(2) :: i,j,m
  integer(2) :: a(:),c(m)
  integer(2) :: complement(m)

  c=1
  c(a)=0
  j=0
  complement=0
  do i=1,m
    if ( c(i) /= 0 ) then
      j=j+1
      complement(j)=i
    end if
  end do
  return
end function complement

function width(i_1,i_2,i_4,i_8)
  integer(1) :: width
  integer(1),optional :: i_1
  integer(2),optional :: i_2
  integer(4),optional :: i_4
  integer(8),optional :: i_8
  character(len=20) :: w

  if ( present(i_1) ) write(w,'(I20)') i_1
  if ( present(i_2) ) write(w,'(I20)') i_2
  if ( present(i_4) ) write(w,'(I20)') i_4
  if ( present(i_8) ) write(w,'(I20)') i_8
  width=len_trim(adjustl(w))
end function width

function norm(A)
  implicit none
  real(8) :: norm
  real(8) :: A(3)

  norm=dsqrt(A(1)**2+A(2)**2+A(3)**2)
  return
end function norm

function cross(A,B)
  implicit none
  real(8) :: cross(3)
  real(8) :: A(3),B(3)

  cross(1)=A(2)*B(3)-A(3)*B(2)
  cross(2)=A(3)*B(1)-A(1)*B(3)
  cross(3)=A(1)*B(2)-A(2)*B(1)
  return
end function cross

function trace(A)
  implicit none
  integer(1) :: trace,A(:,:)

  trace=A(1,1)+A(2,2)+A(3,3)
  return
end function trace

function det(A)
  implicit none
  integer(1) :: det
  integer(1) :: A(3,3)

  det=    A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
  det=det-A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1))
  det=det+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
  return
end function det

function inverse(A)
  implicit none
  integer(1) :: i,j,N
  real(8) :: inverse(3,3)
  real(8) :: A(:,:)
  real(8) :: B(3,3),IA(3,3)

  N=3
  forall(i=1:N,j=1:N,i==j) IA(i,j)=1.D0
  forall(i=1:N,j=1:N,i/=j) IA(i,j)=0.D0
  B=A
  call upper(B,IA,N)
  call lower(B,IA,N)
  forall(i=1:N) IA(i,:)=IA(i,:)/B(i,i)
  inverse=IA
  return
end function inverse

subroutine upper(M,S,N)
  implicit none
  integer(1) :: N
  real(8) :: M(N,N)
  real(8) :: S(N,N)
  integer(1) :: I,J
  real(8) :: E

  do I=1,N-1
    do J=I+1,N
      E=M(J,I)/M(I,I)
      M(J,I:N)=M(J,I:N)-M(I,I:N)*E
      S(J,:)=S(J,:)-S(I,:)*E
    end do
  end do
  return
end subroutine upper

subroutine lower(M,S,N)
  implicit none
  integer(1) :: N
  real(8) :: M(N,N)
  real(8) :: S(N,N)
  integer(1) :: I,J
  real(8) :: E

  do I=N,2,-1
    do J=I-1,1,-1
      E=M(J,I)/M(I,I)
      M(J,I:N)=M(J,I:N)-M(I,I:N)*E
      S(J,:)=S(J,:)-S(I,:)*E
    end do
  end do
  return
end subroutine lower

recursive subroutine sort(A,left,right)
  implicit none
  integer(2),intent(in out) :: A(:)
  integer(2),intent(in) :: left,right
  integer(2) :: temp,t
  integer(2) :: i,j

  if ( left > right ) then
    return
  end if
  temp=A(left)
  i=left
  j=right
  do while ( i /= j )
    do while ( A(j) >= temp .and. i < j )
      j=j-1
    end do
    do while ( A(i) <= temp .and. i < j )
      i=i+1
    end do
    if ( i < j ) then
      t=A(i)
      A(i)=A(j)
      A(j)=t
    end if
  end do
  A(left)=A(i)
  A(i)=temp
  call sort(A,left,i-1_2)
  call sort(A,i+1_2,right)
end subroutine sort

end module functions


!********************************************************************************
!* -- Roe's Flux Function with entropy fix---
!*
!* P. L. Roe, Approximate Riemann Solvers, Parameter Vectors and Difference
!* Schemes, Journal of Computational Physics, 43, pp. 357-372.
!*
!* NOTE: 3D version of this subroutine is available for download at
!*       http://cfdbooks.com/cfdcodes.html
!*
!* ------------------------------------------------------------------------------
!*  Input:   primL(1:4) =  left state (rhoL, uL, vL, pL)
!*           primR(1:4) = right state (rhoR, uR, vR, pR)
!*               njk(2) = Face normal (L -> R). Must be a unit vector.
!*
!* Output:    flux(1:4) = numerical flux
!*                  wsn = half the max wave speed
!*                        (to be used for time step calculations)
!* ------------------------------------------------------------------------------
!*
!* Written by Katate Masatsuka (http://www.cfdbooks.com)
!* Edited  by Nguyen Ngoc Sang (https://github.com/SangVn)
!* ------------------------------------------------------------------------------
!* F2PY - Calling Fortran routines from Python
!* wrap this subroutine to python:
!* python -m numpy.f2py -c fluxes_fortran.f90 -m fluxes_fortran
!********************************************************************************
 subroutine roe(primL, primR, njk,  flux, wsn)
  implicit none

  real(8), parameter :: zero = 0.0, one = 1.0, two = 2.0, half = 0.5, fifth = 1.0/ 5.0, gamma = 1.4, gamma_m1 = 0.4

 !Input:
  real(8), intent( in) :: primL(4), primR(4) ! [rho, u, v, p]_{L,R}
  real(8), intent( in) :: njk(2)             ! Face normal, njk=[nx, ny]

 !Output
  real(8), intent(out) :: flux(4)
  real(8), intent(out) :: wsn

 !Local variables
  real(8) :: nx, ny                  ! Normal vector
  real(8) :: mx, my                  ! Tangent vector: mx*nx+my*ny = 0
  real(8) :: uL, uR, vL, vR          ! Velocity components.
  real(8) :: rhoL, rhoR, pL, pR      ! Primitive variables.
  real(8) :: unL, unR, umL, umR      ! Normal and tangent velocities
  real(8) :: aL, aR, HL, HR          ! Speeds of sound.
  real(8) :: RT,rho,u,v,H,a,un, um   ! Roe-averages
  real(8) :: drho,dun,dum,dp,LdU(4)  ! Wave strenghs
  real(8) :: ws(4), Rv(4,4)          ! Wave speeds and right-eigevectors
  real(8) :: fL(4), fR(4), diss(4)   ! Fluxes ad dissipation term
  real(8) :: dws(4)                  ! User-specified width for entropy fix
  integer :: i, j

  nx = njk(1)
  ny = njk(2)

!Tangent vector (Do you like it? Actually, Roe flux can be implemented
! without any tangent vector. See "I do like CFD, VOL.1" for details.)
  mx = -ny
  my =  nx

!Primitive and other variables.
!  Left state
    rhoL = primL(1)
      uL = primL(2)
      vL = primL(3)
     unL = uL*nx+vL*ny
     umL = uL*mx+vL*my
      pL = primL(4)
      aL = sqrt(gamma*pL/rhoL)
      HL = aL*aL/(gamma_m1) + half*(uL*uL+vL*vL)
!  Right state
    rhoR = primR(1)
      uR = primR(2)
      vR = primR(3)
     unR = uR*nx+vR*ny
     umR = uR*mx+vR*my
      pR = primR(4)
      aR = sqrt(gamma*pR/rhoR)
      HR = aR*aR/(gamma_m1) + half*(uR*uR+vR*vR)

!First compute the Roe Averages
    RT = sqrt(rhoR/rhoL)
   rho = RT*rhoL
     u = (uL+RT*uR)/(one+RT)
     v = (vL+RT*vR)/(one+RT)
     H = (HL+RT* HR)/(one+RT)
     a = sqrt( (gamma_m1)*(H-half*(u*u+v*v)) )
    un = u*nx+v*ny
    um = u*mx+v*my

!Wave Strengths
   drho = rhoR - rhoL
     dp =   pR - pL
    dun =  unR - unL
    dum =  umR - umL

  LdU(1) = (dp - rho*a*dun )/(two*a*a)
  LdU(2) = rho*dum
  LdU(3) =  drho - dp/(a*a)
  LdU(4) = (dp + rho*a*dun )/(two*a*a)

!Wave Speed
  ws(1) = abs(un-a)
  ws(2) = abs(un)
  ws(3) = abs(un)
  ws(4) = abs(un+a)

!Harten's Entropy Fix JCP(1983), 49, pp357-393:
! only for the nonlinear fields.
  dws(1) = fifth
   if ( ws(1) < dws(1) ) ws(1) = half * ( ws(1)*ws(1)/dws(1)+dws(1) )
  dws(4) = fifth
   if ( ws(4) < dws(4) ) ws(4) = half * ( ws(4)*ws(4)/dws(4)+dws(4) )

!Right Eigenvectors
  Rv(1,1) = one
  Rv(2,1) = u - a*nx
  Rv(3,1) = v - a*ny
  Rv(4,1) = H - un*a

  Rv(1,2) = zero
  Rv(2,2) = mx
  Rv(3,2) = my
  Rv(4,2) = um

  Rv(1,3) = one
  Rv(2,3) = u
  Rv(3,3) = v
  Rv(4,3) = half*(u*u+v*v)

  Rv(1,4) = one
  Rv(2,4) = u + a*nx
  Rv(3,4) = v + a*ny
  Rv(4,4) = H + un*a

!Dissipation Term
  diss = zero
  do i=1,4
   do j=1,4
    diss(i) = diss(i) + ws(j)*LdU(j)*Rv(i,j)
   end do
  end do

!Compute the flux.
  fL(1) = rhoL*unL
  fL(2) = rhoL*unL * uL + pL*nx
  fL(3) = rhoL*unL * vL + pL*ny
  fL(4) = rhoL*unL * HL

  fR(1) = rhoR*unR
  fR(2) = rhoR*unR * uR + pR*nx
  fR(3) = rhoR*unR * vR + pR*ny
  fR(4) = rhoR*unR * HR

  flux = half * (fL + fR - diss)
  wsn = half*(abs(un) + a)  !Normal max wave speed times half
  !return
 end subroutine roe


module mod_scal
  use mod_types
  implicit none
  private
  public scal_a,scal_d
  contains
  subroutine scal_d(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,alpha,s,dsdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxc,dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyc,dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzc,dzf
    real(rp), intent(in) :: alpha
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in) :: s
    real(rp), dimension(lo(1):  ,lo(2)  :,lo(3):  ), intent(inout) :: dsdt
    real(rp) :: dsdxp,dsdxm,dsdyp,dsdym,dsdzp,dsdzm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(dsdxp,dsdxm,dsdyp,dsdym,dsdzp,dsdzm) &
    !$OMP SHARED(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,alpha,s,dsdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          dsdxp = (s(i+1,j,k)-s(i  ,j,k))/dxc(i  )
          dsdxm = (s(i  ,j,k)-s(i-1,j,k))/dxc(i-1)
          dsdyp = (s(i,j+1,k)-s(i,j  ,k))/dyc(j  )
          dsdym = (s(i,j  ,k)-s(i,j-1,k))/dyc(j-1)
          dsdzp = (s(i,j,k+1)-s(i,j,k  ))/dzc(k  )
          dsdzm = (s(i,j,k  )-s(i,j,k-1))/dzc(k-1)
          !
          dsdt(i,j,k) = dsdt(i,j,k) + &
                        alpha*(dsdxp-dsdxm)/dxf(i) + &
                        alpha*(dsdyp-dsdym)/dyf(j) + &
                        alpha*(dsdzp-dsdzm)/dzf(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine scal_d
  subroutine scal_a(lo,hi,dxf,dyf,dzf,u,v,w,s,dsdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzf
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: u,v,w,s
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dsdt
    real(rp) :: usip,usim,vsjp,vsjm,wskp,wskm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(usip,usim,vsjp,vsjm,wskp,wskm) &
    !$OMP SHARED(lo,hi,dxf,dyf,dzf,u,v,w,s,dsdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          !
          usim  = 0.5_rp*( s(i-1,j,k)+s(i,j,k) )*u(i-1,j,k)
          usip  = 0.5_rp*( s(i+1,j,k)+s(i,j,k) )*u(i  ,j,k)
          vsjm  = 0.5_rp*( s(i,j-1,k)+s(i,j,k) )*v(i,j-1,k)
          vsjp  = 0.5_rp*( s(i,j+1,k)+s(i,j,k) )*v(i,j  ,k)
          wskm  = 0.5_rp*( s(i,j,k-1)+s(i,j,k) )*w(i,j,k-1)
          wskp  = 0.5_rp*( s(i,j,k+1)+s(i,j,k) )*w(i,j,k  )
          dsdt(i,j,k) = dsdt(i,j,k) + &
                        ( -usip + usim )/dxf(i) + &
                        ( -vsjp + vsjm )/dyf(j) + &
                        ( -wskp + wskm )/dzf(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine scal_a
end module mod_scal


submodule (maptran) enu

implicit none (type, external)

contains

module procedure geodetic2enu
!! geodetic2enu    convert from geodetic to ENU coordinates
!!
!! ## Inputs
!!
!! *  lat,lon, alt:  ellipsoid geodetic coordinates of point under test (degrees, degrees, meters)
!! *  lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
!! *  spheroid: Ellipsoid parameter struct
!! *  angleUnit: string for angular units. Default 'd': degrees
!!
!! ## outputs
!!
!! *  e,n,u:  East, North, Up coordinates of test points (meters)

real(wp) x1,y1,z1,x2,y2,z2, dx,dy,dz

call geodetic2ecef(lat,lon,alt,x1,y1,z1,spheroid,deg)
call geodetic2ecef(lat0,lon0,alt0,x2,y2,z2,spheroid,deg)

dx = x1-x2
dy = y1-y2
dz = z1-z2

call ecef2enuv(dx, dy, dz, lat0, lon0, east, north, up, deg)

end procedure geodetic2enu

module procedure enu2geodetic
! enu2geodetic   convert from ENU to geodetic coordinates
!
! Inputs
! ------
!  East, North, Up: coordinates of point(s) (meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! deg: .true. degrees
!
! outputs
! -------
! lat,lon,alt: geodetic coordinates of test points (degrees,degrees,meters)

real(wp) :: x,y,z

call enu2ecef(east, north, up, lat0, lon0, alt0, x, y, z, spheroid, deg)
call ecef2geodetic(x, y, z, lat, lon, alt, spheroid,deg)

end procedure enu2geodetic

module procedure aer2enu
! aer2enu  convert azimuth, elevation, range to ENU coordinates
!
! Inputs
! ------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon
! angleUnit: string for angular units. Default 'd': degrees
!
! Outputs
! -------
! e,n,u:  East, North, Up coordinates of test points (meters)

real(wp) :: r, a, e
logical :: d

d=.true.
if (present(deg)) d = deg

a = az
e = el
if (d) then
  a = radians(a)
  e = radians(e)
endif

!> Calculation of AER2ENU
up = slantRange * sin(e)
r = slantRange * cos(e)
east = r * sin(a)
north = r * cos(a)

end procedure aer2enu

module procedure enu2aer
!! enu2aer   convert ENU to azimuth, elevation, slant range
!!
!! ## Inputs
!!
!! *  e,n,u:  East, North, Up coordinates of test points (meters)
!! *  deg: .true. degrees
!!
!! ## outputs
!!
!! *  az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
!! *  az: azimuth clockwise from local north
!! *  el: elevation angle above local horizon

real(wp) :: r, e, n, u
logical :: d

real(wp), parameter :: tolerance = 1e-3_wp !< 1mm precision

!> singularity fixes
e = east
if (abs(e) < tolerance) e = 0

n = north
if (abs(n) < tolerance) n = 0

u = up
if (abs(u) < tolerance) u = 0

r = hypot(e, n)
slantRange = hypot(r, u)

!> radians
elev = atan2(u, r)
az = modulo(atan2(e, n), 2 * pi)

d=.true.
if (present(deg)) d = deg

if (d) then
  elev = degrees(elev)
  az = degrees(az)
endif

end procedure enu2aer

end submodule enu


SUBROUTINE FOUR1(DATA,NN,ISIGN)
!
! Replaces data(1:2nn) by its discrete Fourier transform, if isign is 1; or
! with nn times the inverse discrete tranform if isign is -1.  data is a complex
! array of length nn or a real array of length 2*nn.  nn must be an integer
! power of 2.
!
  REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
  DIMENSION DATA(*)
  N=2*NN
  J=1
  DO 11 I=1,N,2
     IF(J.GT.I)THEN
        TEMPR=DATA(J)
        TEMPI=DATA(J+1)
        DATA(J)=DATA(I)
        DATA(J+1)=DATA(I+1)
        DATA(I)=TEMPR
        DATA(I+1)=TEMPI
     ENDIF
     M=N/2
1    IF ((M.GE.2).AND.(J.GT.M)) THEN
        J=J-M
        M=M/2
        GO TO 1
     ENDIF
     J=J+M
11 CONTINUE
  MMAX=2
2 IF (N.GT.MMAX) THEN
     ISTEP=2*MMAX
     THETA=6.28318530717959D0/(ISIGN*MMAX)
     WPR=-2.D0*DSIN(0.5D0*THETA)**2
     WPI=DSIN(THETA)
     WR=1.D0
     WI=0.D0
     DO 13 M=1,MMAX,2
        DO 12 I=M,N,ISTEP
           J=I+MMAX
           TEMPR=SNGL(WR)*DATA(J)-SNGL(WI)*DATA(J+1)
           TEMPI=SNGL(WR)*DATA(J+1)+SNGL(WI)*DATA(J)
           DATA(J)=DATA(I)-TEMPR
           DATA(J+1)=DATA(I+1)-TEMPI
           DATA(I)=DATA(I)+TEMPR
           DATA(I+1)=DATA(I+1)+TEMPI
12      CONTINUE
        WTEMP=WR
        WR=WR*WPR-WI*WPI+WR
        WI=WI*WPR+WTEMP*WPI+WI
13     CONTINUE
       MMAX=ISTEP
       GO TO 2
    ENDIF
    RETURN
  END SUBROUTINE FOUR1


PROGRAM Roots

  COMPLEX :: root
  INTEGER :: i, n
  REAL :: angle, pi

  pi = 4.0 * ATAN(1.0)
  DO n = 2, 7
    angle = 0.0
    WRITE(*,"(I1,A)", ADVANCE="NO") n,": "
    DO i = 1, n
      root = CMPLX(COS(angle), SIN(angle))
      WRITE(*,"(SP,2F7.4,A)", ADVANCE="NO") root, "j  "
      angle = angle + (2.0*pi / REAL(n))
    END DO
    WRITE(*,*)
  END DO

END PROGRAM Roots


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_rot3_unitvec3gen
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the generators for a complex rotation represented
! by 3 real numbers: the real and imaginary parts of a complex cosine,
! CR and CI, and a strictly real sine, S. The CR, CI and S are
! constructed to be parallel with the vector [AR+iAI,B]^T, where AR,
! AI and B are real and i = sqrt(-1).
!
! The vector [AR+iAI,B]^T is assumed to be nearly unit, that is
!
!   abs(AR^2 + AI^2 + B^2 - 1) = O(eps).
!
! In this case it is possible to compute the norm without a squareroot using a
! single newton iteration.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  AR, AI          REAL(8)
!                    real and imaginary part of the first component
!                    of the complex vector [AR+iAI,B]^T
!
!  B               REAL(8)
!                    the second component
!                    of the complex vector [AR+iAI,B]^T
!
! OUTPUT VARIABLES:
!
!  CR, CI          REAL(8)
!                    on exit contains the generators for the cosine
!                    component of the Givens rotation
!
!  S               REAL(8)
!                    on exit contains the generator for the sine
!                    component of the Givens rotation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_rot3_unitvec3gen(AR,AI,B,CR,CI,S)

  implicit none

  ! input variables
  real(8), intent(in) :: AR, AI, B
  real(8), intent(inout) :: CR, CI, S

  ! compute variables
  real(8) :: X

  ! compute difference from unity and approximate 1/sqrt(x)
  X = 5d-1*(3d0 - (AR*AR + AI*AI + B*B))

  ! construct rotation
  CR = AR*X
  CI = AI*X
  S  =  B*X

end subroutine z_rot3_unitvec3gen


      PROGRAM xftest
C     driver for routine ftest
      INTEGER NPTS,NVAL,MPTS
      REAL EPS
      PARAMETER(NPTS=1000,MPTS=500,EPS=0.01,NVAL=10)
      INTEGER i,idum,j
      REAL f,factor,gasdev,prob,var
      REAL data1(NPTS),data2(MPTS),data3(MPTS)
C     generate two Gaussian distributions with
C     different variances
      idum=-13
      do 11 j=1,NPTS
        data1(j)=gasdev(idum)
11    continue
      do 12 j=1,MPTS
        data2(j)=gasdev(idum)
12    continue
      write(*,'(1x,t5,a,f5.2)') 'Variance 1 = ',1.0
      write(*,'(1x,t5,a,t21,a,t30,a)')
     *     'Variance 2','Ratio','Probability'
      do 14 i=1,NVAL+1
        var=1.0+(i-1)*EPS
        factor=sqrt(var)
        do 13 j=1,MPTS
          data3(j)=factor*data2(j)
13      continue
        call ftest(data1,NPTS,data3,MPTS,f,prob)
        write(*,'(1x,f11.4,2x,2f12.4)') var,f,prob
14    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xftest.for


      real function psolR(solD,v,w,x,y)
c
c     + + + PURPOSE + + +
c     Computes potential solar radiation on a sloping surface, in cal/cm2/day
c
c     Called from sunmap.
c     Author(s):
c     Reference: Swift, 1976 "Algorithm for solar radiation on Mountain slopes"
c
c     Date recoded: 11/07/2006.
c     Recoded by: S. Dun
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real solD,v,w,x,y
c
c     + + + ARGUMENT DEFINITIONS + + +
c     solD   - declination of sun
c     v - time offset in hour angle between actual annd equivalent slope
c     w - lattitude of eqivalent slope
c
c     + + + PARAMETERS + + +
c
c     + + + COMMON BLOCKS + + +
c
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + FUNCTION DECLARATIONS + + +

c     + + + END SPECIFICATIONS + + +
c
      psolR = (sin(solD) * sin(w) * (x - y) *12.0 / 3.141593)
     1   + (cos(solD) * cos(w) * (sin(x + v) - sin(y + v))
     2   * 12. / 3.141593)
c
      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     This subroutine enables to calculate the dynamic viscosity of air
!     using Sutherland's formula for gas
!     dvi=dvi0*dsqrt(T/273.d0)*(1.d0+113/273.15)/(1+113/T)
!
!     author: Yannick Muller
!
      subroutine dynamic_viscosity (kgas,T,dvi)
!
      implicit none
!
      integer kgas
!
      real*8 T,dvi
      kgas=kgas
!
      dvi=0.00001711d0*dsqrt(T/273.15d0)*(1d0+113d0/273.15d0)
     &     /(1.d0+113.d0/T)
!
      return
!
      end
!


program matrix_simple
  implicit none

! define a new type mat_obj
  type mat_obj
    integer :: N,M
    real, dimension(:,:), allocatable :: A
  end type mat_obj

! create a new object mat of tpye mat_obj
 type(mat_obj) :: mat

 print*, 'Enter matrix dimension N,M: '
 read*, mat%N, mat%M
 allocate(mat%A(mat%N,mat%M))
!initialize mat with random numbers
 call random_number(mat%A)
! The matrix can be big so we
! write 4 elements only mat%A(1,1),     mat%A(mat%N,1)
!                       mat%A(1,mat%M), mat(mat%N, mat%M)
 print*, mat%A( (/1,mat%N /), (/1, mat%M /) )
 deallocate( mat%A )
end program matrix_simple


module problem

    ! Save the value of k and define the true solution.

    integer :: k
    save

contains

    real(kind=8) function u_true(x,t)
        ! true solution
        implicit none
        real(kind=8), intent(in) :: x, t
        u_true = exp(-k**2 * t) * sin(k*x)
    end function u_true

end module problem


program euler_052
   integer, parameter :: int64 = selected_int_kind(10)
   integer(int64) :: i

   i = 100000
   do
      if (all_digits(i)) then
         print *,i
         stop
      end if
      i = i + 1
   end do !- i

contains
   logical function all_digits(n) result (bool)
      integer(int64), intent(in) :: n
      character(len=6) :: s1,s2
      integer(int64) :: i,j

      write(s1,'(i6)') n
      call sort(s1)

      do i=1,6
         write(s2,'(i6)') i*n
         call sort(s2)

         do j=1,len(s1)
            if (s1(j:j) /= s2(j:j)) then
               bool = .false.
               return
            end if
         end do !- j
      end do

      bool = .true.
      return
   end function all_digits

   pure subroutine sort(s)
      character(len=*), intent(inout) :: s
      character(len=1) :: t
      integer :: i, j

      do i=2,len(s)
         j = i-1
         t(1:1) = s(i:i)
         do while ( j>= 1 .and. s(j:j)>t(1:1))
            s(j+1:j+1) = s(j:j)
            j = j - 1
         end do !- j
         s(j+1:j+1) = t(1:1)
      end do !- i
   end subroutine sort

end program euler_052