!**********************************************************************************************************************************
!
!  Name        : RTB
!  Language    : Fortran 90
!
!  Description : 制限三体問題のゼロ速度曲線を描く
!
!
!  Input
!    Arguments   a  : 中心星と惑星の距離
!                nu : 質量比
!    Terminal  : none
!    File      : none
!
!  Output
!    Arguments : none
!    Terminal  : none
!    File      : out.dat, out1.dat-out7.dat
!
!  Invocation  : none
!
!  Notes       : none
!**********************************************************************************************************************************

PROGRAM RTB
  IMPLICIT NONE

! Constants
  REAL,PARAMETER             :: a  = 1E0                     ! 中心星から惑星までの距離
  REAL,PARAMETER             :: nu = 0.2E0                   ! m2/(m1+m2)

! Internal
  DOUBLE PRECISION :: r1,r2     ! 中心星(惑星)からポテンシャルを求める座標までの距離
	DOUBLE PRECISION :: x,y       ! 位置座標
  DOUBLE PRECISION :: u         ! 回転座標系でのポテンシャル
  INTEGER          :: i,j,num
! Dimension
  REAL,DIMENSION(160000,4) :: S = 0D0

  num=0
  do i = 1,400
    do j = 1,400
      num = num + 1
      x = -2.00D0 + 0.01D0*i
      y = -2.00D0 + 0.01D0*j

      r1 = sqrt( (x + nu*a )**2 + y**2 )
      r2 = sqrt( (x - (1-nu)*a )**2 + y**2 )
      u = ( (1-nu)*(a**3/r1) + nu*(a**3/r2) + 0.5*(x**2+y**2) )
      S(num,2) = x
      S(num,3) = y
      S(num,4) = u
    end do
  end do

num=0
open(10, file="out.dat", status="unknown")
open(11, file="out1.dat", status="unknown")
open(12, file="out2.dat", status="unknown")
open(13, file="out3.dat", status="unknown")
open(14, file="out4.dat", status="unknown")
open(15, file="out5.dat", status="unknown")
open(16, file="out6.dat", status="unknown")
open(17, file="out7.dat", status="unknown")

do num=1,160000
  write(10,*) S(num,2),S(num,3),S(num,4)
  if(S(num,4)>2.2) then
    write(11,*) S(num,2),S(num,3)
  end if
  if(S(num,4)>2.0) then
    write(12,*) S(num,2),S(num,3)
  end if
  if(S(num,4)>1.9) then
    write(13,*) S(num,2),S(num,3)
  end if
  if(S(num,4)>1.8) then
    write(14,*) S(num,2),S(num,3)
  end if
  if(S(num,4)>1.7) then
    write(15,*) S(num,2),S(num,3)
  end if
  if(S(num,4)>1.6) then
    write(16,*) S(num,2),S(num,3)
  end if
  if(S(num,4)>1.5) then
    write(17,*) S(num,2),S(num,3)
  end if
end do

close(10)
close(11)
close(12)
close(13)
close(14)
close(15)
close(16)
close(17)

END PROGRAM


c
c matinv_gold.f solve a set of n linear equations by direct inversion
c          checked for 4x4 random matrix Neil Edwards 13/5/4
c          solves amat*x = rhs, putting result into rhs
c          included in goldstein for case of multiple islands
c          split in to two parts to invert and multiply separately
c          to save a lot of cpu if matrix is constant in time
crma renamed matinv_gold (from matinv) to avoid name conflict (with igcm), 20/9/05
c SAM - 15/4/8 include ocean.cmn here and change size of arrays to be islesmax
c
      subroutine matinv_gold(nvar,amat)

#include "./ocean.cmn"

      integer nvar,i,j,k
      real amat(maxisles,maxisles)
c
c elimination
c
      do i=1,nvar-1
         do j=i+1,nvar
            do k=i+1,nvar
               amat(j,k) = amat(i,i)*amat(j,k) - amat(j,i)*amat(i,k)
            enddo
         enddo
      enddo

      end

      subroutine matmult(nvar,amat,rhs)

#include "./ocean.cmn"

      integer nvar,i,j
      real amat(maxisles,maxisles),rhs(maxisles)

      do i=1,nvar-1
         do j=i+1,nvar
            rhs(j) = amat(i,i)*rhs(j) - amat(j,i)*rhs(i)
         enddo
      enddo
c
c back substitution
c
      rhs(nvar) = rhs(nvar)/amat(nvar,nvar)
      do i=nvar-1,1,-1
         do j=i+1,nvar
            rhs(i) = rhs(i) - amat(i,j)*rhs(j)
         enddo
         rhs(i) = rhs(i)/amat(i,i)
      enddo

c     print*,(rhs(i),i=1,nvar)
c     print*
c     print*,cmat(1,1)*rhs(1) + cmat(1,2)*rhs(2) + cmat(1,3)*rhs(3)
c    1       + cmat(1,4)*rhs(4) - orhs(1),
c    1       cmat(2,1)*rhs(1) + cmat(2,2)*rhs(2) + cmat(2,3)*rhs(3)
c    2       + cmat(2,4)*rhs(4) - orhs(2),
c    2       cmat(3,1)*rhs(1) + cmat(3,2)*rhs(2) + cmat(3,3)*rhs(3)
c    3       + cmat(3,4)*rhs(4) - orhs(3),
c     print*,((amat(i,j),i=1,nvar),j=1,nvar)

      end


      module gaussian_line
      implicit none
      contains
!     ***********************************************************
!     Subroutine to calculate a gaussian lineshape
!     ***********************************************************

      subroutine gline(lshape,lw,xstep,lpts)
      implicit none
      real :: lshape(10000)
      real :: lw, xstep, den, X

      integer lpts,i

      den = lw**2.
      do i= 1, 10000
         lshape(i) = 0
      end do

      X = -5*lw
      do i=1,lpts
         lshape(i) = (0.47/lw)*(-1.38*X/den)*exp(((-0.693)*X**2.)/den)
         lshape(i) = lshape(i) * 100.
         X = X + xstep
      end do

      return
      END subroutine gline
      end module gaussian_line


program auto_allocate
!! demonstrate Fortran 2003 automatic allocation of arrays
!!
!! NOTE: even if an array allocate(), Fortran 2003 still allows auto-reallocation bigger or smaller
!! The A(:) syntax preserves previously allocated LHS shape, truncating RHS

use, intrinsic :: iso_fortran_env, only : stderr=>error_unit, compiler_options
implicit none (type, external)

real, allocatable, dimension(:) :: A, B, C, D, E
real :: C3(3)

print *, compiler_options()

!> Initial auto-allocate
A = [1,2,3]
B = [4,5,6]

C3 = A + B
C = A + B
if (any(C3 /= C)) error stop 'initial auto-allocate'
if (size(C) /= 3) error stop 'initial auto-alloc size'

!> allocate bigger
A = [1,2,3,4]
B = [5,6,7,8]
C = A + B
if (any(C /= [6,8,10,12])) error stop 'auto-alloc smaller'
if (size(C) /= 4) error stop 'auto-alloc bigger size'

!> allocate smaller
A = [1,2]
B = [3,4]
C = A + B
if (any(C /= [4,6])) error stop 'auto-alloc smaller'
if (size(C) /= 2) error stop 'auto-alloc smaller size'

!> fixed allocate first
allocate(D(3), E(3))
D = [1,2]
E = [3,4,5,7]

if (size(D) /= 2) error stop 'allocate() auto-allocate small'
if (size(E) /= 4) error stop 'allocate() auto-allocate big'

!> (:) syntax truncates, does not change shape, whether or not allocate() used first
A(:) = [9,8,7]
if (size(A) /= 2) error stop '(:) syntax smaller'
if (any(A /= [9,8])) error stop '(:) assign small'

E(:) = [1,2,3]
if (size(E) /= 4) error stop 'allocate() (:) syntax small'
if (any(E /= [1,2,3,7])) error stop 'allocate() (:) assign small'

E(:) = [5,4,3,2,1]
if (size(E) /= 4) error stop 'allocate() (:) syntax: big'
if (any(E /= [5,4,3,2])) error stop 'allocate() (:) assign: big'

!> (lbound:ubound)
! A(1:3) = [4,5,6]
! gfortran -fcheck=bounds
! Fortran runtime error: Index '3' of dimension 1 of array 'a' outside of expected range (2:1)
! ifort -CB
! forrtl: severe (408): fort: (10): Subscript #1 of the array A has value 3 which is greater than the upper bound of 2
if (size(A) /= 2) error stop '(l:u) syntax smaller'

print *, 'OK: auto-allocate array'

end program


!********************************************************************************
!>
!  Mullers method derivative free real root finding
!
!  Given a function f of one variable (where f(x) is computed in subroutine
!  fnset as confun(1,1), with:
!
!  * `x = param(1))`
!  * a nonnegative tolerance `tolcon`
!  * two points `(p1,f1)` and `(procor,emin)` with:
!    * `f1 = f(p1)`
!    * `emin = f(procor)`
!    * `p1 < procor`
!    * `f1 > tolcon`
!    * `emin < -tolcon`
!
!  The program will attempt to locate a new `procor` with new `emin = f(procor)`
!  and `abs(emin) <= tolcon`. if it fails to do this, the program will return with
!  `procor` = the leftmost abscissa found with `emin = f(procor) < -tolcon`.
!
!  Note:  if instead of `f1 > tolcon` and `emin < -tolcon` we start with
!  `f1 < -tolcon` and `emin > tolcon`, this program can still be used
!  by replacing `f` by `-f` before running the program.
!
!  The solution procedure is a modification of the following:  bisect the
!  interval [p1,procor] to get a third point, pass a quadratic polynomial
!  through the three points and use its unique zero in [p1,procor] to
!  replace p1 or procor, maintaining the conditions f(left endpoint) >
!  tolcon and f(right endpoint) < -tolcon, and continue until a solution
!  is found or f has been computed 5 times or the interval length falls
!  below 100.0*b**(-itt).  this procedure may be especially useful in cases
!  where f is expensive to compute since it maintains a shrinking interval
!  about the solution, has a higher order of convergence than the regula
!  falsi method, and requires no derivatives.
!
!  The following sample driver
!  program and subroutine fnset are set up to find `procor` in [-4.0,2.0]
!  with abs(f(procor)) <= 0.001, where f(x) = 2.0**(-x) - 0.5
!  (the exact solution is procor = 1.0, emin = 0.0).

module muller_test_module

    use conmax_module, only: conmax_solver
    use iso_fortran_env, only: wp => real64

    implicit none

    private

    type, extends(conmax_solver) :: my_solver
    contains
        procedure :: fnset => my_fnset
    end type my_solver

    public :: muller_test

contains

    subroutine muller_test()

        implicit none

        real(wp) :: dvec(1), emin, err1(4), f1, fun(1), p1, parwrk(1), procor, &
                    pttbl(1, 1), tolcon, work(6), zwork(1)
        integer :: iwork(17)

        type(my_solver) :: solver

        !open (6,file='mulout')

        dvec(1)   = 1.0_wp
        zwork(1)  = 0.0_wp
        iwork(16) = -2
        tolcon    = 1.0e-3_wp
        p1        = -2.0_wp
        f1        = 3.5_wp
        procor    = 2.0_wp
        emin      = -0.25_wp

        write (6, 99001) tolcon, p1, f1, procor, emin
99001   format(/' tolcon is', e22.13//' initially p1 is', e22.13, '  f1 is',&
              & e22.13//' procor is', e22.13, '  emin is', e22.13)

        call solver%muller(0, 1, 1, dvec, fun, 1, pttbl, 1, 1, zwork, tolcon, 0, iwork, 17, &
                           work, 6, parwrk, err1, p1, f1, procor, emin)

        write (6, 99002) procor, emin
99002   format(/' after muller procor is', e22.13//' emin is', e22.13)

    end subroutine muller_test

    subroutine my_fnset(me, nparm, numgr, pttbl, iptb, indm, param, ipt, indfn, &
                        icntyp, confun)
        implicit none

        class(my_solver), intent(inout) :: me
        integer, intent(in)                             :: Nparm
        integer, intent(in)                             :: Numgr
        integer, intent(in)                             :: Iptb
        integer, intent(in)                             :: Indm
        real(wp), dimension(Iptb, Indm), intent(in)     :: Pttbl
        real(wp), dimension(Nparm), intent(in)          :: Param
        integer, intent(in)                             :: Ipt
        integer, intent(in)                             :: Indfn
        integer, dimension(Numgr), intent(out)          :: Icntyp
        real(wp), dimension(Numgr, Nparm + 1), intent(out) :: Confun

        confun(1, 1) = 2.0_wp**(-param(1)) - 0.5_wp

    end subroutine my_fnset

end module muller_test_module

program main
    use muller_test_module
    implicit none
    call muller_test()
end program main

! OUTPUT FOR (A) MULLERS METHOD
!
! TOLCON IS   0.1000000000000E-02
!
! INITIALLY P1 IS  -0.2000000000000E+01  F1 IS   0.3500000000000E+01
!
! PROCOR IS   0.2000000000000E+01  EMIN IS  -0.2500000000000E+00
!
! AFTER MULLER PROCOR IS   0.9993746852789E+00
!
! EMIN IS   0.2167645412207E-03


      FUNCTION CSEDSET(LINDEX,SED,SHEAR,IOPT)
C
C CHANGE RECORD
C
C
C **  CALCULATES CONCENTRATION DEPENDENT SETTLING VELOCITY OF COHESIVE
C **  SEDIMENT
C *** DSLLC BEGIN BLOCK
C
      IF(SED.LE.0.0001)THEN
        CSEDSET=0.0
        RETURN
      ENDIF
C
C *** DSLLC END BLOCK
C **  IOPT=1  BASED ON
C **
C **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
C **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
C **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
C
      IF(IOPT.EQ.1)THEN
        TMP=SED/2000.
        TMP=LOG10(TMP)
        TMP=-16.*TMP*TMP/9.
        TMP=10.**TMP
        CSEDSET=8.E-4*TMP
      ENDIF
C
C **  IOPT=2  BASED ON
C **
C **  SHRESTA, P. L., AND G. T. ORLOB, 1996: MULTIPHASE DISTRIBUTION
C **  OF COHESIVE SEDIMENTS AND HEAVY METALS IN ESTUARINE SYSTEMS,
C **  J. ENVIRONMENTAL ENGINEERING, 122, 730-740.
C
      IF(IOPT.EQ.2)THEN
        SED=1.E-3*SED
        RNG=0.11075+0.0386*SHEAR
        BG=EXP(-4.20706+0.1465*SHEAR)
        WTMP=BG*( SED**RNG )
        CSEDSET=WTMP/3600.
      ENDIF
C
C **  IOPT=3  BASED ON
C **
C **  ZIEGLER, C. K., AND B. S. NESBIT, 1995: LONG-TERM SIMULAITON
C **  OF FINE GRAIN SEDIMENT TRANSPORT IN LARGE RESERVOIR,
C **  J. HYDRAULIC ENGINEERING, 121, 773-781.
C      X 1.E-6
C      TO N/M**2 BY X 1.E+3, CONVERT N/M**2 TO DY/CM**2 BY X 10
C
      IF(IOPT.EQ.3)THEN
        SED=1.E-6*SED
        GG=1.E4*SHEAR
        CG=GG*SED
        CG=MAX(CG,7.51E-6)
        BD2=-0.4-0.25*LOG10(CG-7.5E-6)
        CON=9.6E-4*( (1.E-8)**BD2 )
        VAL=CG**(-0.85-BD2)
        CSEDSET=0.01*CON*VAL
      ENDIF
C
C **  IOPT=4  BASED ON
C
      IF(IOPT.EQ.4)THEN
        GG=1.E4*SHEAR
        TMP=GG*SED
        CSEDSET=8.E-5
        IF(TMP.LT.40.0) CSEDSET=1.51E-5*(TMP**0.45)
        IF(TMP.GT.400.0) CSEDSET=0.893E-6*(TMP**0.75)
      ENDIF
C
C **  IOPT=5  BASED ON HOUSATONIC RIVER
C **     HQ MODIFIED OPTION 5: CONVERT M/DAY TO M/SEC BY /86400
C        INTERSECTION OF THE TWO FUNCTIONS IS AT 3.8 NOT 10.0
C
      IF(IOPT.EQ.5)THEN
        GG=1.E4*SHEAR
        TMP=GG*SED
C
        IF(TMP .LT. 3.8 ) THEN
          CSEDSET = (1.270*(TMP**0.79))/86400. ! 12/31/03 new WP regr
        ELSE
          CSEDSET = (3.024*(TMP**0.14))/86400. ! 12/31/03 Burban&Lick
        ENDIF
      ENDIF
C
C **  IOPT=6
C
      IF(IOPT.EQ.6)THEN
        GG=1.E4*SHEAR
        TMP=GG*SED
        IF(TMP.LT.100.0) CSEDSET=2.*1.16E-5*(TMP**0.5)
        IF(TMP.GE.100.0) CSEDSET=2.*1.84E-5*(TMP**0.4)
      ENDIF
C
C **  IOPT=7  BASED ON
C **
C
      IF(IOPT.EQ.7)THEN
        TMP=SHEAR*SED
        CSEDSET=0.0052*(TMP**0.470138)
      ENDIF
      RETURN
      END


!=====================================================================
   SUBROUTINE mkgrid(z)
!=====================================================================
!  Computes the  the knots for spline calculation in the Rho =Zr
!  variable convenient for scaling.
!---------------------------------------------------------------------
      USE spline_param
      USE spline_grid
      IMPLICIT NONE
      REAL(kind=8), INTENT(IN) :: z
      !INTEGER, INTRINSIC:: NINT
      INTEGER::  i, nt
      REAL(KIND=8):: hp1

      ! .. determine ml, the number of equally spaced steps
      ml = NINT(1.d0/h)
      nt = ns + ks
      nv = ns - ks + 1
      me = nv - ml
      hp1 = 1.d0 + h

      ! .. establish the grid for z*r

      If (Allocated(t)) Deallocate (t)
      ALLOCATE (t(nt))

      ! the multiple knots at the origin
      t(1:ks) = 0.d0

      ! the equally spaced points
      DO i = ks + 1, ks + ml
         t(i) = t(i - 1) + h
      END DO

      ! the exponentially spaced points
      DO i = ks + ml + 1, ns + 1
         t(i) = t(i - 1)*hp1
      END DO

      t(ns + 2:nt) = t(ns + 1)

      ! final knots for r variable
      t = t/z
      rmax = t(ns + 1)
      hmax = rmax - t(ns)
   END SUBROUTINE mkgrid


       SUBROUTINE JACSEQ(A,N,B,X,R,EPS)
C -----------------------------------------------------------
C Resolution du systeme A.X=B de dimension NxN, dimension
C principale de A = N, precision EPS sur la norme du residu
C Version sequentielle de reference
C         -------------------------
C -----------------------------------------------------------
       INTEGER N
       DOUBLE PRECISION A(N,N),B(N),X(N),EPS
C Vecteur residu
       DIMENSION R(N)
       DOUBLE PRECISION R
C Norme du residu
       DOUBLE PRECISION E
C Compteur d'iterations
       INTEGER K
C Procedure de calcul du residu
       EXTERNAL RESIDU
C Fonction de calcul de la norme euclidienne
       EXTERNAL NORM
       DOUBLE PRECISION NORM
       INTEGER I
       INTEGER MAXIT
       PARAMETER (MAXIT=500)
C Initialisation du compteur d'iterations
       K=0
C Initialisation du vecteur iterant
       DO I=1,N
           X(I)=DFLOAT(1)
       END DO
C Calcul du premier residu
       CALL RESIDU(A,N,X,B,R,N)
C Calcul de la premiere norme du residu
       E=NORM(R,N)
C Affichage de la premiere norme du residu
       WRITE(*,*)'***** Iteration ',K,' norme du residu ',E
C Boucle de convergence
       DO WHILE ((E.GT.EPS).AND.(K.LT.MAXIT))
C                                       -1
C          mise a jour de X: X <-- X + D   * R
C          ou D est la diagonale de la matrice
           DO I = 1, N
            X(I) = X(I) +R(I)/A(I,I)
           ENDDO
C          Calcul du nouveau residu
           CALL RESIDU(A,N,X,B,R,N)
C          Calcul de la nouvelle norme du residu
           E=NORM(R,N)
C          Incrementation de la norme du residu
           K=K+1
C          Affichage de la norme du residu
           WRITE(*,*)'***** Iteration ',K,' norme du residu ',E
       ENDDO
C
       RETURN
       END


MODULE BLOCKED_FLOW_Index_new
  !_________________________________________________________________________________________________________!
  !Purpose : In this module contains a set of subroutines and functions to compute blocking index using the !
  !          methodology developed by Tibaldi & Molteni 1990 and by Pelly & Hoskins 2003                    !
  !          * Here the blocking index are computed in 2 dimensions!                                        !
  !                                                                                !
  !Record of Revisions:                                                                                !
  !     DATE                      NAME                            DESCRIPTION                               !
  !     27/08/2013                J.Leandro P.S.Campos            Original code                             !
  !     06/08/2015                J.Leandro P.S.Campos            Revision of some subroutines              !
  !     07/08/2015                J.Leandro P.S.Campos            Subroutine TM_Index added                 !
  !     10/08/2017                J.Leandro P.S.Campos            Main program changed now read netcdf files!
  !     10/08/2017                J.Leandro P.S.Campos            Added lines in blocking Subroutine        !
  !     26/06/2018                J.Leandro P.S.Campos            Added a new subroutine                    !
  !_________________________________________________________________________________________________________!

  IMPLICIT NONE

  REAL,PARAMETER,PRIVATE :: pi = 3.1416                 !number pi
  REAL,PARAMETER,PRIVATE :: a = 6.37E6                  !Earth's radius

  REAL,PARAMETER,PRIVATE :: dphi = 15.0                 !latitudinal blocking extension
  REAL,PARAMETER,PRIVATE :: delta= 4.0                  !Latitudinal allowed variation for blockings
  REAL,PARAMETER,PRIVATE :: l = 7.5                     !maximun gap between two blocked longitudes
  REAL,PARAMETER,PRIVATE :: w = 15.0                    !Minimum blocking width
  REAL,PARAMETER,PRIVATE :: deltalambda = 5.0           !Smooth factor
  REAL,PARAMETER,PUBLIC  :: p = 10.0                    !Overlap parameter

  INTEGER,PARAMETER,PUBLIC :: SINGLE = 4

  !_________________________________________________________________________________________________________!
  ! Blocking Variables (Unused in the main routine - 20/07/2018) Some fortran compilers does nor support this
  TYPE :: blocking_PH                                   !blocking variable for PV-Theta method
    REAL :: index                          !-> binary index
    REAL :: theta                          !-> input variable
    REAL :: dif                            !-> diference
  END TYPE

  TYPE :: blocking_TM                                   !blocking variable for Tibaldi & Molteni's method
    REAL :: index                          !-> binary index
    REAL :: hgt                            !-> input variable
    REAL :: ghgn                           !-> gradient northward central latitude
    REAL :: ghgs                           !-> gradient southward central latitude
  END TYPE
  !________________________________________________________________________________________________________!

  CONTAINS

    SUBROUTINE PH_Index ( ind, B, tht, xdim, ydim, res )
      !Computing the blocking index as in Pelly and Hoslkins (2003)
      IMPLICIT NONE

      INTEGER,INTENT(in) :: xdim, ydim
      REAL,DIMENSION(xdim,ydim),INTENT(in)  :: tht
      REAL,DIMENSION(xdim,ydim),INTENT(out) :: B, ind
      REAL,INTENT(in) :: res

      INTEGER :: dpi, del
      INTEGER :: i, j, k

      ! Computing the difference between the mean southward and equatorward the central latitude j
      dpi = INT(dphi/res)
      DO i = 1, xdim
        DO j = dpi+1, ydim-(dpi+1)
          B(i,j) = (1./REAL(dpi))*( SUM( tht(i,j-dpi:j) ) - SUM( tht(i,j:j+dpi) ) )
        END DO
      END DO

      ! Computing the blocking index if B > 0 -> blocking in the SH
      !                                 B < 0 -> blocking in the NH
      del = INT(delta/res) ; ind = 0.
      DO i = 1, xdim
        DO j = dpi+del, ydim-(dpi+del)

          DO k = j-del, j+del
            IF( j < INT(ydim/2) .and. B(i,k) > 0. ) ind(i,j) = 1
            IF( j > INT(ydim/2) .and. B(i,k) < 0. ) ind(i,j) = 1
          END DO

        END DO
      END DO

    END SUBROUTINE PH_Index

  !________________________________________________________________________________________________________!

    SUBROUTINE TM_INDEX( ind, ghgn, ghgs, hgt, xdim, ydim, res )
      ! Blocking index based on 500hPa Geopotential Height
      IMPLICIT NONE

      INTEGER,INTENT(in) :: xdim, ydim
      REAL,DIMENSION(xdim,ydim),INTENT(inout) :: ghgn, ghgs, ind
      REAL,DIMENSION(xdim,ydim),INTENT(in) :: hgt
      REAL,INTENT(in) :: res

      INTEGER :: dpi, del
      INTEGER :: i, j, k

      ! Computing the GHGN and GHGS parameters
      dpi = INT(dphi/res)
      DO i = 1, xdim
        DO j = dpi+1, ydim-(dpi+1)

          IF( j < INT(ydim/2) )THEN      ! Southern Hemisphere
            GHGN(i,j) = -1*( hgt(i,j)-hgt(i,j+dpi) )/( ANG(j) - ANG(j+dpi) )
            GHGS(i,j) = -1*( hgt(i,j-dpi)-hgt(i,j) )/( ANG(j-dpi) - ANG(j) )
          ELSE IF( j> INT(ydim/2) )THEN  ! Northern Hemisphere
            GHGN(i,j) = ( hgt(i,j+dpi)-hgt(i,j) )/( ANG(j+dpi) - ANG(j) )
            GHGS(i,j) = ( hgt(i,j)-hgt(i,j-dpi) )/( ANG(j) - ANG(j-dpi) )
          END IF

        END DO
      END DO

      ! Computing the blocking index
      del = INT(delta/res) ; ind = 0.
      DO i = 1, xdim
        DO j = dpi+del, ydim-(dpi+del)

          DO k = j-del, j+del
            IF( j<INT(ydim/2) .and. (GHGS(i,j)<-10. .and. GHGN(i,j)>0.) ) ind(i,j) = 1.
            IF( j>INT(ydim/2) .and. (GHGS(i,j)>0. .and. GHGN(i,j)<-10.) ) ind(i,j) = 1.
          END DO

        END DO
      END DO

      END SUBROUTINE TM_INDEX

      REAL FUNCTION ANG( val )
        IMPLICIT NONE

        INTEGER,INTENT(iN) :: val
        INTEGER :: res = 1.5

        ANG = -90 + res*(val-1)
        RETURN
      END FUNCTION ANG

  !________________________________________________________________________________________________________!

    SUBROUTINE GLBI ( ind, xdim, ydim, res )
      IMPLICIT NONE

      INTEGER,INTENT(in) :: xdim, ydim
      REAL,DIMENSION(xdim,ydim),INTENT(inout) :: ind
      REAL,INTENT(in) :: res

      INTEGER :: i, j, k, par, ww

      ! Fill all the gaps of l degrees between contiguous blocked longitudes
      par = INT(l/res)
      DO j = 1, ydim
        DO i = 1, xdim-par

          IF( INT(ind(i,j)) == 1 )THEN
            DO k = i+par, i, -1
              IF( INT(ind(k,j)) == 1 )THEN
                ind(i:k,j ) = 1. ; EXIT
              END IF
            END DO
          END IF

        END DO
      END DO

      !Fill the gaps between +1 or -1 latitude grids (added in 17/08/2016)
      DO i = 1, xdim
        DO j = 2, ydim-1

          IF( ind(i,j-1) == 1 .and. ind(i,j+1) == 1 )THEN
            ind(i,j) = 1.
          END IF

        END DO
      END DO

      ww = INT(w/res)
      ! Group all blocked latitudes with minimum width of W degrees
      DO j = 1, ydim
        DO i = 2, xdim
          IF( ind(i,j) > 0. ) ind(i,j) = ind(i,j) + ind(i-1,j)
        END DO
        DO i = xdim-1, 1, -1
          IF( ind(i,j) > 0 .and. ind(i+1,j) > 0. ) ind(i,j) = ind(i+1,j)
        END DO
      END DO
      WHERE( ind < REAL(ww) ) ind = 0.
      WHERE( ind >=REAL(ww) ) ind = 1.

    END SUBROUTINE GLBI
    !________________________________________________________________________________________________________!

    !________________________________________________________________________________________________________!

    SUBROUTINE BLOCKING (blk, ind, xdim, ydim, tdim, res, persistence )
      IMPLICIT NONE

      INTEGER,INTENT(in) :: xdim, ydim, tdim, persistence
      REAL,INTENT(in) :: res
      REAL,DIMENSION(xdim,ydim,tdim),INTENT(in) :: ind
      REAL,DIMENSION(xdim,ydim,tdim),INTENT(inout) :: blk
      REAL,DIMENSION(xdim,ydim,tdim) :: xind

      INTEGER :: i, j, t, pp
      REAL :: val

      ! If day t-1 and t+1 are blocked and day t is not blocked, day t is also blocked. (Added 10/08/2017)
      xind = ind
      DO t = 2, tdim-1
        DO i = 1,xdim
          DO j = 1,ydim
            IF( xind(i,j,t)<1. .and. ( xind(i,j,t-1)>0. .and. xind(i,j,t+1)>0. ) ) xind(i,j,t) = xind(i,j,t-1);
          END DO
		END DO
      END DO

      ! Find all group of blocked longitudes one day prior and after the blocked flow that overlap at least p degrees.
      !xind = ind ;
      pp = INT(p/res)
      DO t = 2, tdim
        DO j = 1, ydim
          DO i = 1, xdim
            IF( xind(i,j,t)>0. .and. xind(i,j,t-1)>0. ) xind(i,j,t)=xind(i,j,t)+xind(i,j,t-1)
          END DO
        END DO
      END DO

      DO t = tdim-1, 1, -1
        DO j = 1, ydim
          DO i = 1, xdim
            IF( xind(i,j,t) > 0. .and. xind(i,j,t+1) > 0. ) xind(i,j,t) = xind(i,j,t+1)
          END DO
        END DO
      END DO

      DO t = 1, tdim-1

        DO j = 1, ydim-pp
          DO i = 1, xdim-pp
            val = MAXVAL( xind(i:i+pp, j:j+pp, t) )
            WHERE( xind(i:i+pp, j:j+pp, t)>0. ) xind(i:i+pp, j:j+pp, t) = val
          END DO
        END DO

        DO j = ydim, pp+1, -1
          DO i = xdim, pp+1, -1
            val = MAXVAL( xind(i-pp:i, j-pp:j, t) )
            WHERE( xind(i-pp:i, j-pp:j, t)>0. ) xind(i-pp:i, j-pp:j, t) = val
          END DO
        END DO

      END DO

      ! All blocked flow are blocking if last at least persistence days
      blk = 0.
      WHERE( xind >= REAL(persistence) ) blk = 1.

    END SUBROUTINE BLOCKING

    !________________________________________________________________________________________________________________!

    SUBROUTINE SMOOTH(input,output, xdim, ydim, tdim, res)
      ! This subroutine smooth the data in deltalambda degrees
      ! Use this before perform the blocked flow index for the
      ! Potential Temperature field

      INTEGER,INTENT(in) :: xdim, ydim,tdim
      REAL,INTENT(in) :: res
      REAL,DIMENSION(xdim,ydim,tdim) :: input
      REAL,DIMENSION(xdim,ydim,tdim) :: output
      INTEGER :: i,j,t,smth

      smth = INT( (deltalambda/res)/2. )

      DO t = 1,tdim
        DO j = 1,ydim
          DO i = 1,xdim

            IF( i > smth .or. i < (xdim-smth) )THEN
              output(i,j,t) = SUM(input(i-smth:i+smth,j,t))/REAL(2*smth)
            ELSE IF( i < smth )THEN
              output(i,j,t) = (SUM(input(smth-i:i+smth,j,t))+SUM(input(xdim-smth:xdim,j,t)))/REAL(2*smth)
            ELSE IF( i > xdim-smth )THEN
              output(i,j,t) = (SUM(input(i-smth:xdim,j,t))+SUM(input(1:xdim-i,j,t)))/REAL(2*smth)
            ELSE IF( i == smth )THEN
              output(i,j,t) = ( SUM(input(1:smth,j,t))+input(xdim,j,t))/REAL(2*smth)
            ELSE IF( i == xdim-smth )THEN
              output(i,j,t) = ( SUM(input(xdim-smth:smth,j,t))+input(1,j,t))/REAL(2*smth)
            END IF

          END DO
        END DO
      END DO

    END SUBROUTINE SMOOTH

    !______________________________________________________________________________________!
    SUBROUTINE DAILY_MEANS(input, output, xdim, ydim, tdim, time1day)

       INTEGER,INTENT(in) :: xdim, ydim, tdim
       INTEGER,INTENT(in) :: time1day
       REAL,DIMENSION(xdim,ydim,tdim),INTENT(in) :: input
       REAL,DIMENSION(xdim,ydim,INT(tdim/4)),INTENT(out):: output
       REAL,DIMENSION(xdim,ydim) :: med
       INTEGER :: t, k, i

       i = 1;
       DO t = 1,tdim,time1day
         med = 0
         DO k = t,t+time1day-1
           med = input(:,:,k)+med
         END DO
         output(:,:,i) = med/REAL(time1day)
         i = i+1
       END DO

    END SUBROUTINE DAILY_MEANS

END MODULE BLOCKED_FLOW_Index_new


! -----------------------------------------------------------------------------
!
! Copyright (c) 2009 - 2012 Chris Martin, Kasia Boronska, Jenny Young,
! Peter Jimack, Mike Pilling
!
! Copyright (c) 2017 Sam Cox, Roberto Sommariva
!
! This file is part of the AtChem2 software package.
!
! This file is covered by the MIT license which can be found in the file
! LICENSE.md at the top level of the AtChem2 distribution.
!
! -----------------------------------------------------------------------------

! ******************************************************************** !
! ATCHEM2 -- MODULE solarFunctions
!
! This module contains functions that calculate quantities related to
! relative positions of the Earth and Sun.
! ******************************************************************** !
module solar_functions_mod
  implicit none

contains

  ! -----------------------------------------------------------------
  ! Calculate the day angle (radians). Equations taken from "The
  ! Atmosphere and UV-B Radiation at Ground Level" by S. Madronich
  ! (Environmental UV Photobiology, 1993).
  pure function calcTheta() result ( theta )
    use types_mod
    use date_mod, only : currentYear, currentDayOfYear

    real(kind=DP) :: theta, pi

    pi = 4.0_DP * atan( 1.0_DP )

    ! The day angle accounts for the variation in the Sun-Earth
    ! distance caused by the ellipticity of the Earth's orbit.
    if ( (mod(currentYear, 4_DI)==0 .and. .not. mod(currentYear, 100_DI)==0) .or. (mod(currentYear, 400_DI)==0) ) then
      ! leap year
      theta = 2.0_DP * pi * currentDayOfYear / 366.0_DP
    else
      ! not a leap year
      theta = 2.0_DP * pi * currentDayOfYear / 365.0_DP
    end if

    return
  end function calcTheta

  ! -----------------------------------------------------------------
  ! Calculate the sun declination (radians). Equations taken from "The
  ! Atmosphere and UV-B Radiation at Ground Level" by S. Madronich
  ! (Environmental UV Photobiology, 1993).
  pure function decFromTheta( theta ) result ( dec )
    use types_mod

    real(kind=DP), intent(in) :: theta
    real(kind=DP) :: b0, b1, b2, b3, b4, b5, b6, dec

    b0 =  0.006918_DP
    b1 = -0.399912_DP
    b2 =  0.070257_DP
    b3 = -0.006758_DP
    b4 =  0.000907_DP
    b5 = -0.002697_DP
    b6 =  0.001480_DP

    dec = b0 + b1 * cos(theta) + b2 * sin(theta) + b3 * cos(2.0_DP * theta) + &
          b4 * sin(2.0_DP * theta) + b5 * cos(3.0_DP * theta) + b6 * sin(3.0_DP * theta)

    return
  end function decFromTheta

  ! -----------------------------------------------------------------
  ! Calculate the sun declination (radians). Firstly update theta
  ! (day angle) to today's value, then calculate dec from that.
  pure function calcDec() result ( dec )
    use types_mod

    real(kind=DP) :: theta, dec

    theta = calcTheta()

    ! The sun declination is the angle between the center of the Sun
    ! and Earth's equatorial plane.
    dec = decFromTheta( theta )

    return
  end function calcDec

  ! -----------------------------------------------------------------
  ! The equation of time accounts for the discrepancy between the
  ! apparent and the mean solar time at a given location.
  pure function calcEQT() result ( eqt )
    use types_mod

    real(kind=DP) :: c0, c1, c2, c3, c4, theta, eqt

    theta = calcTheta()

    c0 = 0.000075_DP
    c1 = 0.001868_DP
    c2 = -0.032077_DP
    c3 = -0.014615_DP
    c4 = -0.040849_DP
    eqt = c0 + c1 * cos(theta) + c2 * sin(theta) + c3 * cos(2.0_DP * theta) + &
          c4 * sin(2.0_DP * theta)

    return
  end function

  ! -----------------------------------------------------------------
  ! Calculate the local hour angle (radians) and the solar zenith
  ! angle (radians). Equations taken from "The Atmosphere and UV-B
  ! Radiation at Ground Level" by S. Madronich (Environmental UV
  ! Photobiology, 1993).
  subroutine calcZenith( t, dec )
    use types_mod
    use zenith_data_mod, only : eqtime, lha, latitude, longitude, sinld, cosld, &
                                cosx, secx, cosx_threshold, cosx_below_threshold

    real(kind=DP), intent(in) :: t, dec
    real(kind=DP) :: pi, lat
    real(kind=DP) :: currentFracHour

    pi = 4.0_DP * atan( 1.0_DP )

    ! The local hour angle is the angle between the observer's
    ! meridian and the Sun's meridian. Time must be in GMT/UTC and
    ! longitude in degrees.
    !
    ! TODO: currentFracDay is wrong because t/86400 is not the
    ! fractional time of day (eg: 12:00 = 0.5). This is only used to
    ! calculate currentFracHour. The error in the calculation of LHA
    ! is very small but it needs to be fixed
    eqtime = calcEQT()

    ! Calculate the fraction of the day in units of hours - convert from
    ! seconds to hours, then mod 24 to remove any previous days' hours.
    currentFracHour = mod( t / 3600.0_DP, 24.0_DP )

    lha = pi * ((currentFracHour / 12.0_DP) - (1.0_DP + longitude / 180.0_DP)) + eqtime

    ! The solar zenith angle is the angle between the local vertical
    ! and the center of the Sun. Latitude must be in radians.
    lat = latitude * pi / 180.0_DP
    sinld = sin( lat ) * sin( dec )
    cosld = cos( lat ) * cos( dec )
    ! Calculate the cosine of the solar zenith angle.
    cosx = cos( lha ) * cosld + sinld

    ! Set negative cosx to zero and calculate the inverse
    ! (secx=1/cosx). The MCM photolysis parameterisation
    ! (http://mcm.leeds.ac.uk/MCM/parameters/photolysis_param.htt)
    ! requires cosx and secx to calculate the photolysis rates.
    if ( cosx <= cosx_threshold ) then
      cosx = 0.0_DP
      secx = 1.0e+2_DP
      cosx_below_threshold = .true.
    else
      secx = 1.0_DP / cosx
      cosx_below_threshold = .false.
    end if

    return
  end subroutine calcZenith

end module solar_functions_mod


      SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
*  -- LAPACK driver routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      COMPLEX            AB( LDAB, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  CPBSV computes the solution to a complex system of linear equations
*     A * X = B,
*  where A is an N-by-N Hermitian positive definite band matrix and X
*  and B are N-by-NRHS matrices.
*
*  The Cholesky decomposition is used to factor A as
*     A = U**H * U,  if UPLO = 'U', or
*     A = L * L**H,  if UPLO = 'L',
*  where U is an upper triangular band matrix, and L is a lower
*  triangular band matrix, with the same number of superdiagonals or
*  subdiagonals as A.  The factored form of A is then used to solve the
*  system of equations A * X = B.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The number of linear equations, i.e., the order of the
*          matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
*          On entry, the upper or lower triangle of the Hermitian band
*          matrix A, stored in the first KD+1 rows of the array.  The
*          j-th column of A is stored in the j-th column of the array AB
*          as follows:
*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
*          See below for further details.
*
*          On exit, if INFO = 0, the triangular factor U or L from the
*          Cholesky factorization A = U**H*U or A = L*L**H of the band
*          matrix A, in the same storage format as A.
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
*          On entry, the N-by-NRHS right hand side matrix B.
*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the leading minor of order i of A is not
*                positive definite, so the factorization could not be
*                completed, and the solution has not been computed.
*
*  Further Details
*  ===============
*
*  The band storage scheme is illustrated by the following example, when
*  N = 6, KD = 2, and UPLO = 'U':
*
*  On entry:                       On exit:
*
*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
*
*  Similarly, if UPLO = 'L' the format of A is as follows:
*
*  On entry:                       On exit:
*
*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
*
*  Array elements marked * are not used by the routine.
*
*  =====================================================================
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           CPBTRF, CPBTRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CPBSV ', -INFO )
         RETURN
      END IF
*
*     Compute the Cholesky factorization A = U'*U or A = L*L'.
*
      CALL CPBTRF( UPLO, N, KD, AB, LDAB, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
      END IF
      RETURN
*
*     End of CPBSV
*
      END


program myprog
  use utility
  use gauss
  implicit none

  integer, allocatable :: edge_matrix(:, :)
  integer num_columns, num_rows, i, j
  real time1, time2
  integer, allocatable :: test_ops(:, :)
  num_columns = 1400
  num_rows = 700
  call cpu_time(time1)
  allocate(edge_matrix(num_rows, num_columns))
  do i = 1, num_rows
    do j = 1, num_columns
      edge_matrix(i, j) = random_int(0, 1)
    enddo
  enddo
  call cpu_time(time2)
  print *, "init: ", time2 - time1

  ! do j=1, num_rows
  !   write(*,"(10(I2,a))") (edge_matrix(j, i),',',i = 1, num_columns)
  ! enddo

  call cpu_time(time1)
  call echelon(edge_matrix)
  call cpu_time(time2)
  print *, "echelon: ", time2 - time1

  call cpu_time(time1)
  call row_sort(edge_matrix)
  call cpu_time(time2)
  print *, "sort: ", time2 - time1

  ! print *, "============================================"

  ! do j=1, num_rows
  !  write(*,"(10(I2,a))") (edge_matrix(j, i),',',i = 1, num_columns)
  ! enddo

  call cpu_time(time1)
  call backsolve(edge_matrix)
  call cpu_time(time2)
  print *, "backsolve: ", time2 - time1

  call cpu_time(time1)
  test_ops = decode(edge_matrix)
  call cpu_time(time2)
  print *, "decode: ", time2 - time1

  ! print *, "============================================"
  ! do j=1, num_columns
  !  write(*,"(10(I2,a))") (test_ops(j, i),',',i = 1, num_columns)
  ! enddo

end program myprog


c
c***********************************************************************
c
      subroutine tanhds (ns, sp1, sp2, s, status)
c
c***************
c
c    Program by:  jc vassberg    copyright (c) 2000
c    Written on:  19 apr 2000
c    Updated on:  19 apr 2000
c
c***************
c
c    TANHDS computes a normalized arclength distribution based on the
c    hyperbolic tangent function.  Spacings can be specified at either
c    or both ends.  See Joe Thompson's grid generation book.
c
c    Nomenclature
c    ------------
c        ns:  number of points in distribution     (input)
c       sp1:  normalized initial spacing           (input)
c       sp2:  normalized final spacing             (input)
c    status:  error status, ge.0 = no errors       (output)
c         s:  normalized arclength distribution    (output)
c
c    Notes
c    -----
c      * A two-sided distribution results for sp1 > 0.0 and sp2 > 0.0
c        with initial spacing (sp1) and final spacing (sp2)
c
c      * A one-sided distribution results for sp1 > 0.0 and sp2 = 0.0
c        with initial spacing (sp1)
c
c      * A one-sided distribution results for sp1 = 0.0 and sp2 > 0.0
c        with final spacing (sp2)
c
c      * Equal spacing results if sp1 = sp2 = 0.0
c
c      * Iterates until (delta sp < tol*sp) or (iter = itmx)
c
c      * TANHDS calls:  functions ZSINHV & ATANHV
c
c***************
c
      implicit none
c
      integer
     .   ns, status,
     .   i, j, iter, itmx, n, nm1, nsmid
c
      real*8
     .   sp1, sp2, s(ns), si, sj,
     .   a, atanhv, aterm, b, bterm, c, cterm,
     .   del, del1, del2, delcmp, delta, delta1,
     .   denom, divfac, zsinhv, f, fp, fpa, fpb,
     .   fpc, pct, tol,
     .   pct1, pct2, scmp, scmp1, scmp2,
     .   sp, u, u1, u2, xden, xintnh,
     .   xnm1, xnum, xnum1, xnum2, xnumer
c
c***************
c
c    Initialize
      status    = 0
      itmx      = 100
      tol       = 0.005d0
c     tol       = 0.0005d0
c     tol       = 0.0001d0
      s(1)      = 0.d0
      s(ns)     = 1.d0
      nm1       = ns - 1
      xnm1      = dble(nm1)
      nsmid     = (ns + 1) / 2
c
c    Done
      if (ns .eq. 2) then
       goto 999
      endif
c
c    Bad input
      if (ns .lt. 2) then
         status    = -1
         goto 999
      endif
c
c    Bad input
      if ((sp1 .lt. 0.d0) .or. (sp2 .lt. 0.d0)) then
         status    = -1
         goto 999
      endif
c
c    Hyperbolic tangent distribution (two-sided)
      if ((sp1 .gt. 0.d0) .and. (sp2 .gt. 0.d0)) then
c
c       Bad input
         if ((sp1+sp2) .gt. 1.d0) then
            status    = -1
            goto 999
         endif
c
c       Initial guess for delta
         b         = 1.d0 / (xnm1*sqrt(sp1*sp2))
         delta     = zsinhv(b)
         delta1    = delta
c
c       Bad input
         if (b .eq. 1.d0) then
            status    = -1
            goto 999
         endif
c
         iter      = 1
  200    continue
            if (b .gt. 1.d0) then
               c         = (tanh(delta*((1.d0/xnm1)-0.5d0))
     .                     /tanh(0.5d0*delta))
               a         = (1.d0+c-sp1-(c*sp1)) / (sp1-c*sp1)
               denom     = sp2*(a-1.d0) - a
               xnumer    = (tanh(0.5d0*delta))*(a-sp2-a*sp2)
               xintnh    = atanhv(-xnumer/denom)
               divfac    = ((xnm1-1.d0)/xnm1) - 0.5d0
               delcmp    = xintnh / divfac
               xnum1     = tanh(delcmp*(1.d0/xnm1-0.5d0))
               xnum2     = tanh(delcmp*((xnm1-1.d0)/xnm1-0.5d0))
               xden      = tanh(0.5d0*delcmp)
            else
     .      if (b .lt. 1.d0) then
               c         = (tan(delta*((1.d0/xnm1)-0.5d0))
     .                     /tan(0.5d0*delta))
               a         = (1.d0+c-sp1-(c*sp1)) / (sp1-c*sp1)
               denom     = sp2*(a-1.d0) - a
               xnumer    = (tan(0.5d0*delta))*(a-sp2-a*sp2)
               xintnh    = atan(-xnumer/denom)
               divfac    = ((xnm1-1.d0)/xnm1) - 0.5d0
               delcmp    = xintnh / divfac
               xnum1     = tan(delcmp*(1.d0/xnm1-0.5d0))
               xnum2     = tan(delcmp*((xnm1-1.d0)/xnm1-0.5d0))
               xden      = tan(0.5d0*delcmp)
            endif
c
c          Check for convergence
            u1        = 0.5d0*(1.d0+xnum1/xden)
            scmp1     = u1 / (a+(1.d0-a)*u1)
            u2        = 0.5d0*(1.d0+xnum2/xden)
            scmp2     = 1.d0 - (u2/(a+(1.d0-a)*u2))
            del1      = abs(sp1-scmp1)
            del2      = abs(sp2-scmp2)
            pct1      = del1 / sp1
            pct2      = del2 / sp2
c
c          Not converged
            if ((pct1 .gt. tol) .or. (pct2 .gt. tol)) then
               delta     = delcmp
               iter      = iter + 1
               if (iter .lt. itmx) then
                  goto 200
               else
                  delta     = delta1
                  if (b .gt. 1.d0) then
                     c         = (tanh(delta*((1.d0/xnm1)-0.5d0))
     .                           /tanh(0.5d0*delta))
                  else
     .            if (b .lt. 1.d0) then
                     c         = (tan(delta*((1.d0/xnm1)-0.5d0))
     .                           /tan(0.5d0*delta))
                  endif
                  a         = (1.d0+c-sp1-(c*sp1))/(sp1-c*sp1)
                  delcmp    = delta
               endif
            endif
c        end-loop-200
c
c       Converged
         status    = iter
         delta     = delcmp
         do 210  i = 2,nm1
            if (b .gt. 1.d0) then
               xnum      = tanh(delta*(dble(i-1)/xnm1-0.5d0))
               xden      = tanh(0.5d0*delta)
            else
     .      if (b .lt. 1.d0) then
               xnum      = tan(delta*(dble(i-1)/xnm1-0.5d0))
               xden      = tan(0.5d0*delta)
            endif
            u         = 0.5d0*(1.d0+xnum/xden)
            s(i)      = u / (a+(1.d0-a)*u)
  210    continue
c
c    Hyperbolic tangent distribution (one-sided)
      else
     .if ((sp1 .gt. 0.d0) .or. (sp2 .gt. 0.d0)) then
c
c       Bad input
         if ((sp1 .gt. 0.5d0) .or. (sp2 .gt. 0.5d0)) then
            status    = -1
            goto 999
         endif
c
         if (sp1 .gt. 0.d0) sp = sp1
         if (sp2 .gt. 0.d0) sp = sp2
c
c       Initial guess for delta
         b         = 1.d0 / (xnm1*sp)
         delta     = zsinhv(b)
         delta1    = delta
         iter      = 1.d0
         aterm     = 0.5d0*((1.d0/xnm1)-1.d0)
         bterm     = 0.5d0
         cterm     = sp - 1.d0
  100    continue
            if (b .gt. 1.d0) then
               f         = tanh(aterm*delta)/tanh(bterm*delta) - cterm
               fpa       = aterm*tanh(bterm*delta)/cosh(aterm*delta)**2
               fpb       = bterm*tanh(aterm*delta)/cosh(bterm*delta)**2
               fpc       = tanh(bterm*delta)**2
            else
     .      if (b .lt. 1.d0) then
               f         = tan(aterm*delta)/tan(bterm*delta) - cterm
               fpa       = aterm*tan(bterm*delta)/cos(aterm*delta)**2
               fpb       = bterm*tan(aterm*delta)/cos(bterm*delta)**2
               fpc       = tan(bterm*delta)**2
            endif
            fp        = (fpa - fpb) / fpc
            delcmp    = delta - (f/fp)
            if (b .gt. 1.d0) then
               c         = tanh((0.5d0*delcmp)*((1.d0/xnm1)-1.d0))
               a         = tanh(0.5d0*delcmp)
            else
     .      if (b .lt. 1.d0) then
               c         = tan((0.5d0*delcmp)*((1.d0/xnm1)-1.d0))
               a         = tan(0.5d0*delcmp)
            endif
            scmp      = 1.d0 + c/a
            del       = abs(sp - scmp)
            pct       = del / sp
c
c          Not converged
            if (pct .gt. tol) then
               delta     = delcmp
               iter      = iter + 1
               if (iter .lt. itmx) then
                  goto 100
               else
                  delta     = delta1
                  if( b .gt. 1.d0 )then
                     a      = tanh(0.5d0*delta)
                  else
     .            if (b .lt. 1.d0) then
                     a      = tan(0.5d0*delta)
                  endif
                  delcmp = delta
               endif
            endif
c        end-loop-100
c
c       Converged
         status    = iter
         delta     = delcmp
         do 110  i = 2,nm1
           if (b .gt. 1.d0) then
              c         = tanh((0.5d0*delta)*((dble(i-1)/xnm1)-1.d0))
              s(i)      = 1.d0 + c/a
           else
     .     if (b .lt. 1.d0) then
              c         = tan((0.5d0*delta)*((dble(i-1)/xnm1)-1.d0))
              s(i)      = 1.d0 + c/a
           endif
  110    continue
c
c       Swap direction if required
         if (sp2 .gt. 0.d0) then
            do 120  i = 1,nsmid
               j         = ns + 1 - i
               si        = 1.d0 - s(i)
               sj        = 1.d0 - s(j)
               s(i)      = sj
               s(j)      = si
  120       continue
         endif
c
c    Equal spacing distribution (no-sided)
      else
         do 10   n = 2,nm1
            s(n)       = dble(n-1) / xnm1
   10    continue
      endif
c
  999 continue
c
      return
      end
c
c**********************************************************************
c
      real*8 function zsinhv(b)
c
c***************
c
c    program by:  jc vassberg    copyright (c) 2000
c    written on:  19 apr 2000
c    updated on:  19 apr 2000
c
c***************
c
c    ZSINHV finds x for an approximate zero of:
c       sin(x)/x - b  for  0.0 < b < 1.0
c      sinh(x)/x - b  for  1.0 < b
c
c***************
c
      implicit none
c
c***************
c
      real*8
     .   b, b1, pi, v, w, c1, c2, c3, c4, c5
c
c***************
c
c    Approximate root of sin(x)/x - b
      if ((b .gt. 0.d0) .and. (b .lt. 1.d0)) then
         if (b .le. 0.26938972d0) then
            pi        = 4*atan(1.d0)
            c1        = 11.726095d0
            c2        = 13.205501d0
            c3        =  6.794732d0
            zsinhv    = pi*((((((c1*b-c2)*b+c3)*b
     .                  -(1.d0+pi*pi/6.d0))*b+1.d0)*b-1.d0)*b+1.d0)
         else
            b1        = 1.d0 - b
            c1        = 0.075845134d0
            c2        = 0.053337753d0
            c3        = 0.048774238d0
            c4        = 0.057321429d0
            c5        = 0.150000000d0
            zsinhv    = sqrt(6.d0*b1)
     .                  *(((((c1*b1-c2)*b1+c3)*b1+c4)*b1+c5)*b1+1.d0)
         endif
c
c    Approximate root of sinh(x)/x - b
      else
     .if (b .gt. 1.d0) then
         if (b .le. 2.7829681d0) then
            b1        = b - 1.0
            c1        = 0.0010794123d0
            c2        = 0.0077424461d0
            c3        = 0.0249072950d0
            c4        = 0.0573214290d0
            c5        = 0.1500000000d0
            zsinhv    = -sqrt(6.d0*b1)
     .                  *(((((c1*b1-c2)*b1+c3)*b1-c4)*b1+c5)*b1-1.d0)
         else
            v         = log(b)
            w         = 1.d0/b - 0.028527431d0
            c1        = 8.56795911d0
            c2        = 2.62945470d0
            c3        = 1.94964430d0
            c4        = 0.24902722d0
            c5        = 0.02041793d0
            zsinhv    = v + (1.d0+1.d0/v)*log(2.d0*v)
     .                    + (((c1*w-c2)*w+c3)*w+c4)*w - c5
         endif
      else
         zsinhv    = 0.d0
      endif
c
      return
      end
c
c**********************************************************************
c
      real*8 function atanhv(x)
c
c***************
c
c    program by:  jc vassberg    copyright (c) 2000
c    written on:  19 apr 2000
c    updated on:  19 apr 2000
c
c***************
c
c    ATANHV finds the arc-hyperbolic-tangent of x.
c
c***************
c
      implicit none
c
c***************
c
      real*8
     .   x
c
c***************
c
      if (abs(x) .ge. 1.d0) then
         atanhv    = 0.d0
      else
         atanhv    = 0.5d0*log((1.d0+x)/(1.d0-x))
      endif
c
      return
      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_rot2_fuse
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the product of two real Given's rotations and
! and stores the output in one of the input arrays.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  DIR             LOGICAL
!                    .TRUE.: A = A*B
!                    .FALSE.: B = A*B
!
!  A,B             REAL(8) array of dimension (2)
!                    generators for rotations
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_rot2_fuse(DIR,A,B)

  implicit none

  ! input variables
  logical, intent(in) :: DIR
  real(8), intent(inout) :: A(2), B(2)

  ! compute variables
  real(8) :: c, s, nrm

  ! merge at top
  if(DIR)then

    ! compute new generators
    c = A(1)*B(1)-A(2)*B(2)
    s = A(2)*B(1)+A(1)*B(2)

    ! compute new generators
    call d_rot2_vec2gen(c,s,A(1),A(2),nrm)

  ! merge at bottom
  else

    ! compute new generators
    c = A(1)*B(1)-A(2)*B(2)
    s = A(2)*B(1)+A(1)*B(2)

    ! compute new generators
    call d_rot2_vec2gen(c,s,B(1),B(2),nrm)

  end if

end subroutine d_rot2_fuse


submodule(geometry_t_interface) geometry_t_implementation
  !! Define the grain geometry user-defined structure constructors and geometrical formulas
  implicit none
contains

  module procedure new_geometry_t
    new_geometry_t%vol_    = vol
    new_geometry_t%id_     = id
    new_geometry_t%od_     = od
    new_geometry_t%length_ = length
  end procedure

  module procedure incremented_geometry_t
    incremented_geometry_t%id_     = old_geometry_t%id_
    incremented_geometry_t%od_     = old_geometry_t%od_
    incremented_geometry_t%length_ = old_geometry_t%length_
    incremented_geometry_t%vol_    = old_geometry_t%vol_ + volume_increment
  end procedure

  module procedure surf
    use constants, only : pi, zero

    associate(db=>(burn_depth))
      associate(id=>(this%id_), od=>(this%od_), length=>(this%length_))
        surf = merge(zero, pi*(id+2.0d0*db)*(length-2.0d0*db)+0.5d0*pi*(od**2.0d0-(id+2.0*db)**2.0d0), this%burnout(db))
      end associate
    end associate

  end procedure

  module procedure burnout
    associate(id=>(this%id_), od=>(this%od_), length=>(this%length_))
      burnout = id+2*db>od .or. db>length/2
    end associate
  end procedure

  module procedure vol
    vol = this%vol_
  end procedure

end submodule geometry_t_implementation


program IntegrationTest
  use Integration
  use FunctionHolder
  implicit none

  print *, integrate(afun, 0., 3**(1/3.), method='simpson')
  print *, integrate(afun, 0., 3**(1/3.), method='leftrect')
  print *, integrate(afun, 0., 3**(1/3.), method='midrect')
  print *, integrate(afun, 0., 3**(1/3.), method='rightrect')
  print *, integrate(afun, 0., 3**(1/3.), method='trapezoid')

end program IntegrationTest


!Calculate the portion of the writhe that changes during a crankshaft move

subroutine writhe_crank(R, IT1, IT2, N, Wr)
   use params, only: dp
   implicit none

   real(dp), PARAMETER :: PI = 3.141592654d0 ! Value of pi

   integer, intent(in) :: N                 ! Number of beads
   real(dp), intent(in) :: R(3, N)  ! Positions
   !Geometric variables
   real(dp) r1(3)                  ! Position bead 1
   real(dp) r2(3)                  ! Position bead 2
   real(dp) r12(3)                 ! Relative position vector
   real(dp) s1                     ! Length of segment 1
   real(dp) s2                     ! Length of segment 2
   real(dp) beta                   ! Angle between tangents
   real(dp) e1(3)                  ! Tangent of first segment
   real(dp) e2(3)                  ! Tangent of second segment
   real(dp) e3(3)
   integer DIB, DIO                         !Number of segments inside section rotated,outside

   !Counter variables
   integer IT1, IT2                         !Indices of endpoints in segment rotated
   integer II, IO                           !Index of bead inside segment rotated,outside
   integer I, IP1
   integer J, JP1

   real(dp) dWr
   real(dp), intent(out) :: Wr      ! Writhe

   Wr = 0.
   if (IT2 >= IT1) then
      DIB = IT2 - IT1
   else
      DIB = (N - IT1) + IT2
   ENDif

   DIO = N - DIB
   II = IT1

   do I = 1, DIB

      if (II == N) then
         IP1 = 1
      elseif (II == N + 1) then
         II = 1
         IP1 = II + 1
      else
         IP1 = II + 1
      ENDif
      IO = IT2
      do J = 1, DIO

         if (IO == N) then
            JP1 = 1
         elseif (IO == N + 1) then
            IO = 1
            JP1 = IO + 1
         else
            JP1 = IO + 1
         ENDif

         r1 = R(:, II)
         r2 = R(:, IO)
         r12 = r2 - r1

         s2 = SQRT(SUM((R(:, JP1) - R(:, IO))**2))
         s1 = SQRT(SUM((R(:, IP1) - R(:, II))**2))
         e2 = (R(:, JP1) - R(:, IO))/s2
         e1 = (R(:, IP1) - R(:, II))/s1

         CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
         !Wr = 0 for segments in plane (Wr = NaN)
         if (dWr /= dWr) then
            dWr = 0.
         endif
         !Wr = 0 for adjacent segments
         if (JP1 == II .OR. IP1 == IO) then
            dWr = 0.
         endif

         Wr = Wr + dWr

         IO = IO + 1

      ENDdo
      II = II + 1
   ENDdo

   Wr = 2.*Wr

   RETURN
END subroutine writhe_crank


!*****************************************************************!
!                            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

  implicit none

  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, temp
  real*8, dimension(:), pointer :: U => null(), F => null()
  real*8, dimension(3) :: A
  real*8,dimension(5) :: param
  character(len=32) :: arg
  integer :: comm

  call mpi_init(statinfo)

  ! The program takes at least one parameter: the initial temperature
  narg = iargc()
  param(:) = 0
  if (narg .lt. 2) then
    print*,"Missing parameter"
    stop
  endif
  ! 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
  temp = param(1)

  ! The new MPI communicator, process rank and communicator size
  call MPI_Comm_dup(MPI_COMM_WORLD, 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, temp)
  ! init A (tridiagonal matrix):
  call filling_A(d, dx, dy, dt, nx, ny, A) ! fill A

  ! 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
    print*, 'Time step:', t
  end do

  ! write results on disk
  call finalize(dx, dy, nx, ny, i1, in, u, f, me, 0)

  ! end timer
  t2 = mpi_wtime()
  print*, 'Calcul time:', t2-t1, 'sec'

  deallocate(U, F)

  call mpi_finalize(statinfo)

end program heat