program fft_timing

  use decomp_2d
  use decomp_2d_fft
  use MPI

  implicit none

  integer, parameter :: nx=17, ny=13, nz=11
  integer, parameter :: p_row=0, p_col=0

  integer, parameter :: NTEST = 10  ! repeat test this times

  complex(mytype), allocatable, dimension(:,:,:) :: in, out
  real(mytype), allocatable, dimension(:,:,:) :: in_r

  integer, dimension(3) :: fft_start, fft_end, fft_size

  real(mytype) :: dr,di, err, err_all, n1,flops
  integer :: ierror, i,j,k,m
  double precision :: t1, t2, t3 ,t4

  call MPI_INIT(ierror)
  call decomp_2d_init(nx,ny,nz,p_row,p_col)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Test the c2c interface
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call decomp_2d_fft_init(PHYSICAL_IN_Z) ! non-default Z-pencil input

  !  input is Z-pencil data
  ! output is X-pencil data
  allocate (in(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))
  allocate (out(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
  ! initilise input
  do k=zstart(3),zend(3)
     do j=zstart(2),zend(2)
        do i=zstart(1),zend(1)
           dr = real(i,mytype)/real(nx,mytype)*real(j,mytype) &
                /real(ny,mytype)*real(k,mytype)/real(nz,mytype)
           di = dr
           in(i,j,k) = cmplx(dr,di,mytype)
        end do
     end do
  end do

  t2 = 0.0D0
  t4 = 0.0D0
  do m=1,NTEST

     ! forward FFT
     t1 = MPI_WTIME()
     call decomp_2d_fft_3d(in, out, DECOMP_2D_FFT_FORWARD)
     t2 = t2 + MPI_WTIME() - t1

     ! inverse FFT
     t3 = MPI_WTIME()
     call decomp_2d_fft_3d(out, in, DECOMP_2D_FFT_BACKWARD)
     t4 = t4 + MPI_WTIME() - t3

     ! normalisation - note 2DECOMP&FFT doesn't normalise
     in = in / real(nx,mytype) / real(ny,mytype) /real(nz,mytype)

  end do

  call MPI_ALLREDUCE(t2,t1,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
       MPI_COMM_WORLD,ierror)
  t1 = t1 / real(nproc,mytype)
  call MPI_ALLREDUCE(t4,t3,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
       MPI_COMM_WORLD,ierror)
  t3 = t3 / real(nproc,mytype)

  ! checking accuracy
  err = 0.
  do k=zstart(3),zend(3)
     do j=zstart(2),zend(2)
        do i=zstart(1),zend(1)
           dr = real(i,mytype)/real(nx,mytype)*real(j,mytype) &
                /real(ny,mytype)*real(k,mytype)/real(nz,mytype)
           di = dr
           dr = dr - real(in(i,j,k),mytype)
           di = di - aimag(in(i,j,k))
           err = err + sqrt(dr*dr + di*di)
        end do
     end do
  end do
  call MPI_ALLREDUCE(err,err_all,1,real_type,MPI_SUM,MPI_COMM_WORLD,ierror)
  err_all = err_all / real(nx,mytype) / real(ny,mytype) / real(nz,mytype)

  if (nrank==0) then
     write(*,*) '===== c2c interface ====='
     write(*,*) 'error / mesh point: ', err_all
     write(*,*) 'time (sec): ', t1,t3
     n1 = real(nx,mytype) * real(ny,mytype) * real(nz,mytype)
     n1 = n1 ** (1._mytype/3._mytype)
     ! 5n*log(n) flops per 1D FFT of size n using Cooley-Tukey algorithm
     flops = 5._mytype * n1 * log(n1) / log(2.0_mytype)
     ! 3 sets of 1D FFTs for 3 directions, each having n^2 1D FFTs
     flops = flops * 3._mytype * n1**2
     flops = 2._mytype * flops / ((t1+t3)/real(NTEST,mytype))
     write(*,*) 'GFLOPS : ', flops / 1000._mytype**3
  end if

  deallocate(in,out)
  call decomp_2d_fft_finalize

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Test the r2c/c2r interface
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  call decomp_2d_fft_init

  allocate (in_r(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
  call decomp_2d_fft_get_size(fft_start,fft_end,fft_size)
  allocate (out(fft_start(1):fft_end(1), &
       fft_start(2):fft_end(2), &
       fft_start(3):fft_end(3)))

  ! initilise input
  do k=xstart(3),xend(3)
     do j=xstart(2),xend(2)
        do i=xstart(1),xend(1)
           in_r(i,j,k) = real(i,mytype)/real(nx,mytype)*real(j,mytype) &
                /real(ny,mytype)*real(k,mytype)/real(nz,mytype)
        end do
     end do
  end do

  t2 = 0.0D0
  t4 = 0.0D0
  do m=1,NTEST

     ! 3D r2c FFT
     t1 = MPI_WTIME()
     call decomp_2d_fft_3d(in_r, out)
     t2 = t2 + MPI_WTIME() - t1

     ! 3D inverse FFT
     t3 = MPI_WTIME()
     call decomp_2d_fft_3d(out, in_r)
     t4 = t4 + MPI_WTIME() - t3

     ! normalisation - note 2DECOMP&FFT doesn't normalise
     do k=xstart(3),xend(3)
        do j=xstart(2),xend(2)
           do i=xstart(1),xend(1)
              in_r(i,j,k) = in_r(i,j,k) &
                   / (real(nx,mytype)*real(ny,mytype)*real(nz,mytype))
           end do
        end do
     end do

  end do

  call MPI_ALLREDUCE(t2,t1,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
       MPI_COMM_WORLD,ierror)
  t1 = t1 / real(nproc,mytype)
  call MPI_ALLREDUCE(t4,t3,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
       MPI_COMM_WORLD,ierror)
  t3 = t3 / real(nproc,mytype)

  ! checking accuracy
  err = 0.
  do k=xstart(3),xend(3)
     do j=xstart(2),xend(2)
        do i=xstart(1),xend(1)
           dr = real(i,mytype)/real(nx,mytype)*real(j,mytype) &
                /real(ny,mytype)*real(k,mytype)/real(nz,mytype)
           err = err + abs(in_r(i,j,k)-dr)
        end do
     end do
  end do
  call MPI_ALLREDUCE(err,err_all,1,real_type,MPI_SUM,MPI_COMM_WORLD,ierror)
  err_all = err_all / real(nx,mytype) / real(ny,mytype) / real(nz,mytype)

  if (nrank==0) then
     write(*,*) '===== r2c/c2r interface ====='
     write(*,*) 'error / mesh point: ', err_all
     write(*,*) 'time (sec): ', t1,t3
  end if

  deallocate(in_r,out)
  call decomp_2d_fft_finalize
  call decomp_2d_finalize
  call MPI_FINALIZE(ierror)

end program fft_timing


MODULE FUN_xyLINE
!!#### PURPOSE
!! Determine a line in R^2 <xyLINE_> using:
!!  @ two points <PP>,
!!  @ point and a vector <PV>, or a
!!  @ point and a direction <PU>.

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

!!#### EXTERNAL PROCEDURES
USE FUN_xyDIRECTION,ONLY: xyDIRECTION_V        !!((04-B-FUN_xyDIRECTION.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyLINE_PP
 MODULE PROCEDURE xyLINE_PP_Rsp
 MODULE PROCEDURE xyLINE_PP_Rdp
END INTERFACE

INTERFACE xyLINE_PV
 MODULE PROCEDURE xyLINE_PV_Rsp
 MODULE PROCEDURE xyLINE_PV_Rdp
END INTERFACE

INTERFACE xyLINE_PU
 MODULE PROCEDURE xyLINE_PU_Rsp
 MODULE PROCEDURE xyLINE_PU_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyLINE_PP
PUBLIC :: xyLINE_PV
PUBLIC :: xyLINE_PU

CONTAINS

PURE FUNCTION xyLINE_PP_Rsp( P_a , P_b ) RESULT( xyLn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyLINE_PP.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyLINE_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyLINE_PP_Rdp( P_a , P_b ) RESULT( xyLn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyLINE_PP.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyLINE_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyLINE_PV_Rsp( P , V ) RESULT( xyLn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyLINE_PV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyLINE_PV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyLINE_PV_Rdp( P , V ) RESULT( xyLn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyLINE_PV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyLINE_PV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyLINE_PU_Rsp( P , U ) RESULT( xyLn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyLINE_PU.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyLINE_PU.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyLINE_PU_Rdp( P , U ) RESULT( xyLn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyLINE_PU.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyLINE_PU.f90.bdy"
!!--end--
END FUNCTION

END MODULE


       SUBROUTINE AITOFF(ALAT,ALONG,AITLAT,AITLON)
C**********************************************************************
C       SUBROUTINE AITOFF CONVERTS LONGITUDE AND LATITUDE IN RADIANS TO
C       AITOFF'S PROJECTION OF THE SPHERE(ALSO IN RADIANS).
C       THE FORMULAE USED IN THIS SUBROUTINE WERE TAKEN FROM
C       COORDINATE SYSTEMS AND MAP PROJECTIONS,MALING.
C**********************************************************************
C       THIS SUBROUTINE WAS CREATED BY BARBARA H ROBERTS,1/81.
C       UPDATED.....
C*********************************************************************
C       VARIABLE DESCRIPTION
C       NAME      TYPE       I/O        DIM       DESCRIPTION
C       ALAT      R*8         I          1        LATITUDE
C       ALONG     R*8         I          1        LONGITUDE
C       AITLAT    R*8         O          1        AITOFF LATITUDE
C       AITLON    R*8         O          1        AITOFF LONGITUDE
C*********************************************************************
C       AITOFF'S PROJECTION WAS MISTAKENLY CONFUSED
C       WITH HAMMER-AITOFF'S EQUAL AREA PROJECTION OF THE SPHERE
C       UNTIL 1952. AT THAT TIME IT WAS DISCOVERED THAT HAMMER(1892)
C       HAD INVENTED THE PROJECTION. SINCE THAT TIME THE PROJECTION
C       (EQUAL AREA) HAS BEEN CALLED HAMMER-AITOFF OR JUST HAMMER'S
C       PROJECTION.(SEE INTRODUCTION TO MAP PROJECTIONS BY PORTER
C       W. MCDONNELL,JR.P.112.)AITOFF'S PROJECTION(1889) IS NOT
C       AN EQUAL AREA PROJECTION,BUT ONE IN WHICH THERE IS EQUAL
C       DISTANCE BETWEEN PARALLELS. THIS SUBROUTINE IS THE FORTRAN
C       CODE FOR THE OLDER PROJECTION, THE EQUAL DISTANCE BETWEEN
C       PARALLELS,NOT THE EQUAL AREA PROJECTION.
C**********************************************************************
C
C  CODED BY BARBARA ROBERTS. 5/81.
C   MODIFIED.....
C
C
      IMPLICIT REAL*8(A-H,O-Z)
C
C****************************************************************
C
      REAL*8 HALFPI/ 1.570796326794897D0 /
      REAL*8 PI/ 3.141592653589793D0 /
      REAL*8 TWOPI/ 6.283185307179586D0 /
C
C FACLAT,FACLON HAVE VALUES OF + OR - 1 SO THAT FIRST QUADRANT
C VALUES OF AITLAT AND AITLON CAN GENERATE OTHER THREE QUADRANTS
C
      REAL*8 FACLAT(4)/2*1.0D0,2*-1.0D0/,FACLON(4)/1.0D0,2*-1.0D0,1.0D0/
      DATA EPS/ 1.0D-8 /
      XLAT=ALAT
      XLONG=ALONG
C
C THE VARIABLE TEMP IS EQUIVALENT TO XLONG BUT HAS VALUE BETWEEN
C ZERO AND 360 DEGREES AND IS POSITIVE
C
      TEMP=DMOD(DABS(XLONG),TWOPI)
C
C DSIGN TRANSFERS SIGN ON XLONG TO TEMP
C
      XLONG=DSIGN(TEMP,XLONG)
      IF ((DABS(XLONG)-PI).LT.EPS) GO TO 500
      IF(DABS(XLONG).GT.PI) XLONG=XLONG-DSIGN(TWOPI,XLONG)
C
C THE FOLLOWING FOUR IF STATEMENTS USE SIGNS ON XLAT AND XLONG
C TO DETERMINE QUADRANT. THE VALUES OF IQUAD ARE THE RESULTANT
C QUADRANTS
C
500   IF((XLAT.LT.0.0).AND.(XLONG.GE.0.0))IQUAD=4
      IF((XLAT.LT.0.0).AND.(XLONG.LT.0.0))IQUAD=3
      IF((XLAT.GE.0.0).AND.(XLONG.LT.0.0))IQUAD=2
      IF((XLAT.GE.0.0).AND.(XLONG.GE.0.0))IQUAD=1
      XLAT=DABS(XLAT)
      XLONG=DABS(XLONG)
C
C THE AITOFF TRANSFORMATION FOR FIRST QUADRANT LATITUDE AND LONGITUDE
C
      TEMPZ=DCOS(XLAT)*DCOS(.5D0*XLONG)
      Z=DACOS(TEMPZ)
      ALPHA=HALFPI
      IF(XLAT.LT.EPS)GO TO 200
      ALPHA=0.0D0
      IF((HALFPI-XLAT).LT.EPS)GO TO 200
      IF((XLONG.LT.EPS).OR.(DABS(TWOPI-XLONG).LT.EPS)) GO TO 200
      CALPHA=DTAN(XLAT)*(1.0D0/DSIN(.5D0*XLONG))
      ALPHA=DATAN2(1.0D0,CALPHA)
C
200   AITLON=2.0D0*Z*DSIN(ALPHA)
      AITLAT=Z*DCOS(ALPHA)
C
C FACTORS FACLAT AND FACLON PLACE AITLAT AND AITLON IN PROPER
C QUADRANTS
C
      AITLAT=FACLAT(IQUAD)*AITLAT
      AITLON=FACLON(IQUAD)*AITLON
      RETURN
      END


\ goly.f
\ ------------------------------------------------------------------------

 .( loading goly.f ) cr

\ LANGUAGE    : ANS Forth            <-- not true in x4
\ PROJECT     : Forth Environment
\ DESCRIPTION : Counting Sallow's Golygons
\ CATEGORY    : Example
\ AUTHOR      : Marcel Hendrix, July 1990
\ LAST CHANGE : February 15, 1992, Marcel Hendrix

\ Smarter method (than the one exposed in GOLYGONS) to COUNT golygons.
\ For more info on golygosofical issues, read A.K. Dewdney's 'Mathematical
\ Recreations' column in the 'Scientific American' of July 1990.
\
\ "A golygon consists of straight-line segments that have lengths (measured in
\ miles, meters or whatever unit you prefer) of one, two, three and so on, up
\ to some finite number. Every segment connects at a right angle to the segment
\ that is one unit larger - except the longest segment, which meets the
\ shortest segment at a right angle."
\
\                                +2
\                       +8    +1xxxxxx
\                xxxxxxxxxxxxxxxx    x
\                x                 -3x   8-sided golygon.
\                x          xxxxxxxxxx
\             +7 x          x   -4
\                x          x -5
\                x          x
\                x          x
\                xxxxxxxxxxxx
\                      -6
\
\ Studying above scetch, you will notice that 3 further golygons can be drawn
\ by simple mirroring the image. We don't want to count these. This is most
\ easily done by requiring that the first two segments are ALWAYS 1 up, 2 to
\ the right, followed by 6 further, non-obvious steps.
\
\ We can make use of the proof given by Sallow, Gardner, Knuth and Guy that
\ golygons must be of order 8k where k is an integer.
\ Note that the problem can be separated in two almost independent subproblems.
\ All even steps are x-steps, and the sum of the x-movements should be zero.
\ All odd steps are y-steps, and the sum of the y-movements should also be zero.
\ The advantage of this separation is that we can stop as soon as the
\ X-displacement is not zero.
\ This trick can be combined with the symmetry argument: The first x-step
\ and y-step are fixed. Furthermore, we do not check for a zero effective
\ X-movement, but for ABS(movement) to be order-1 at the (order/2-1)th step.
\
\ Finally, realize that we only want to COUNT the golygons, not to explicitly
\ CALCULATE them (as done in GOLYGONS). This means that we can count the
\ possible X- and Y-step sequences separately and then multiply them to get
\ the answer.
\
\ For the problem above, a brute force method checks all 2^8 possible
\ direction sequences to see if they result in a closed curve. Using separation,
\ we'll only check 2^(8/2-2) cases of which only a limited amount ask
\ for a further 2^2 checks.
\
\ This package does not allow k larger than 8, which is a limitation imposed
\ by 32-bit integers.
\
\ Sample Output
\ =============
\ The number of  8-sided golygons is 1          0.003 s used.
\ The number of 16-sided golygons is 28         0.008 s used.
\ The number of 24-sided golygons is 2108       0.135 s used.
\ The number of 32-sided golygons is 227332     2.823 s used.
\ The number of 40-sided golygons is 30276740   56.166 s used.
\
\ It seems that if the number gets 256 times larger, we need 20 times as much
\ time to compute its golygons.
\
\ Knuth has written a program that can compute all golygons with 64 sides and
\ found 127,674,038,970,623. If you have a computer 1000 * faster than our 25
\ MHz T800, the Forth program presented here will still take
\
\        (20)^3 * 1 minute / 1000  = 8 minutes
\
\ Maybe Knuth has used such a beast, but I think it is more likely that he has
\ found some very smart shortcuts.

\ ------------------------------------------------------------------------

0 var #found            \ must work for k=8 (2^64 solutions possible)

: ++found +!> #found ;  \ <n> --- <>

8 var order             \ number of golygon sides
1 var distance          \ length current golygon side

0 var temp              \ values are faster than stack ops.
\ ------------------------^--another not true in x4--^

\ ------------------------------------------------------------------------

: prepare
  68 min 4 max !> order     \ <n> --- <>
  off> #found               \ number of unique golygons
  cr ." Goly "
\  cr order . ." -sided Golygon."
  timer-reset ;

\ ------------------------------------------------------------------------

: .result
  .elapsed
  ." (found " #found . ')' emit ;

\  ." golygon"
\  order 8 <>
\  if 's' emit then
\  space .elapsed ;

\ ------------------------------------------------------------------------

: (checkout)    ( n1 temp --- result )
  order 2/ 2- 0
  ?do
    distance
    pluck 1 and 0=
    if
       negate
    then
    +
    swap 2/ swap
    2 +!> distance
  loop
  nip abs ;

\ ------------------------------------------------------------------------

\ The first Y step is ALWAYS up (1), so the Y start position is 1.
\ The question is: will we end up in |Order-1| after (Order/2)-2 steps?

: checkouty     ( n1 --- f1 )
  3 !> distance
  1 (checkout)
  order 1- = ;

\ ------------------------------------------------------------------------

\ The first X step is ALWAYS right (1), so the X start position is 2.
\ The question is: will we end up in |Order| after (Order/2)-2 steps?

: checkoutx
  4 !> distance
  2 (checkout)
  order = ;

\ ------------------------------------------------------------------------

0 var xsolutions

: xcompute
  off> xsolutions
  1 order 2/ 2 - <<
  begin
  1-
    dup checkoutx
    if
      incr> xsolutions
    then
    dup 0=
  until
  drop ;

\ ------------------------------------------------------------------------

: ycompute
  1 order 2/ 2 - <<
  begin
  1-
    dup checkouty
    if
      xsolutions ++found
    then
    dup 0=
  until
  drop ;

\ ------------------------------------------------------------------------

: ?goly ( n --- )
  prepare xcompute ycompute
  .result ;

\ ------------------------------------------------------------------------
\ this takes 19 seconds on my k6-3/550 - 48 ?goly takes 11 mins

: goly-bench 40 ?goly ;     \ 56 ?goly only takes 4 and a half hours :P

\ ------------------------------------------------------------------------
\ ABOUT    Type <n> ?golygons   where 4 <= <n> <= 68." ;
\ ========================================================================


!! main subroutines for optimization scheme
!! modified by Wenyong Pan
!!!!!!!!!!!!!!!! OPTIMIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine SD(g_new, NSTEP, p_new)
    use constants
    implicit none

    !! steepest descent method
    real(kind=CUSTOM_REAL), dimension(*), intent(in) :: g_new
    integer, intent(in) :: NSTEP
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: p_new

    !! initialization
    p_new (1:NSTEP) = 0.0_CUSTOM_REAL

    !! SD
    p_new(1:NSTEP) = - g_new(1:NSTEP)

end subroutine SD

subroutine LCG(g_new, NSTEP, CG_method, cgstep, p_new)
    use constants
    implicit none

    !! steepest descent method
    real(kind=CUSTOM_REAL), dimension(*), intent(in) :: g_new
    integer, intent(in) :: NSTEP
    character(len=2), intent(in) :: CG_method
    integer, intent(out) :: cgstep
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: p_new

    !! initialization
    p_new (1:NSTEP) = 0.0_CUSTOM_REAL

    !! SD
    p_new(1:NSTEP) = - g_new(1:NSTEP)

end subroutine LCG

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine NLCG(g_new, g_old, p_old, NSTEP, CG_method, cgstep, p_new)
    !! non-linear conjugate method
    !! NOTES :: The biggest threat to the CG method is a loss of conjugacy in the search vectors
    !! one way is to periodically restart the CG method
    use constants
    implicit none

    real(kind=CUSTOM_REAL), dimension(*), intent(in) :: g_new, g_old, p_old
    integer, intent(in) :: NSTEP
    character(len=2), intent(in) :: CG_method
    integer, intent(out) :: cgstep
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: p_new

    real(kind=CUSTOM_REAL) :: beta
    real(kind=CUSTOM_REAL) :: top, bot

    !! initialization
    p_new (1:NSTEP) = 0.0
    cgstep = cgstep+1

    !! beta formula
    select case (CG_method)
    case ("FR") ! Fletcher-Reeves
        top = sum(g_new(1:NSTEP) * g_new(1:NSTEP))
        bot = sum(g_old(1:NSTEP) * g_old(1:NSTEP))
        beta = top / bot
    case ("PR") ! Polak-Ribiere
        top = sum(g_new(1:NSTEP) * (g_new(1:NSTEP)-g_old(1:NSTEP)))
        bot = sum(g_old(1:NSTEP) * g_old(1:NSTEP))
        beta = top / bot
    case ("HS") ! Hestenes-Stiefel
        top = sum(g_new(1:NSTEP) * (g_new(1:NSTEP)-g_old(1:NSTEP)))
        bot = -1.0 * sum(p_old(1:NSTEP) * (g_new(1:NSTEP)-g_old(1:NSTEP)))
        beta = top / bot
    case ("DY") ! Dai-Yuan:
        top = sum(g_new(1:NSTEP) * g_new(1:NSTEP))
        bot = -1.0 * sum(p_old(1:NSTEP) * (g_new(1:NSTEP)-g_old(1:NSTEP)))
        beta = top / bot
    case default
        print*, 'CG_method must be among "FR"/"PR"/"HS"/"DY" ...';
        stop
    end select

    ! handle loss of conjugacy that results from the non-quadratic terms
    if(beta<=0.0) then
        print*, 'restarting NLCG ... [negative beta]'
        beta = 0.0
        cgstep = 1
    elseif (dot_product(p_new(1:NSTEP), g_new(1:NSTEP)) > 0.0) then
        print*, 'restarting NLCG ... [not a descent direction]'
        beta = 0.0
        cgstep = 1
    elseif (abs(dot_product(g_new(1:NSTEP), g_old(1:NSTEP)) &
            / dot_product(g_new(1:NSTEP), g_new(1:NSTEP))) > CG_threshold ) then
        print*, 'restarting NLCG ... [loss of conjugacy]'
        beta = 0.0
        cgstep = 1
    endif  !! restart NLCG

    !! search direction
    p_new(1:NSTEP) = - g_new(1:NSTEP) + beta * p_old(1:NSTEP)

end subroutine NLCG
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine LBFGS(Dm, Dg, g_new, NSTEP, m, BFGS_step, p_new)
    !! Quasi-Newton method (L-BFGS)
    use constants
    implicit none

    integer, intent(in) :: NSTEP, m
    real(kind=CUSTOM_REAL), intent(in) :: Dm(NSTEP,m),Dg(NSTEP,m)
    real(kind=CUSTOM_REAL), dimension(*), intent(in) :: g_new
    integer, intent(out) :: BFGS_step ! for next iter
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: p_new

    real(kind=CUSTOM_REAL), dimension(m) :: alpha, beta, rho
    integer :: i
    real(kind=CUSTOM_REAL), dimension(NSTEP) :: q, z
    real(kind=CUSTOM_REAL) :: invH

    !! initialization
    p_new (1:NSTEP) = 0.0

    !!  initialization
    q(1:NSTEP) = g_new(1:NSTEP)

    !! the first loop
    do i = 1, m
    rho(i) = 1.0/dot_product(Dg(1:NSTEP,i),Dm(1:NSTEP,i))
    alpha(i) = rho(i) * dot_product(Dm(1:NSTEP,i), q(1:NSTEP))
    q(1:NSTEP) = q(1:NSTEP) - alpha(i) * Dg(1:NSTEP,i)
    enddo

    invH = dot_product(Dg(1:NSTEP,1), Dm(1:NSTEP,1)) / &
        dot_product(Dg(1:NSTEP,1), Dg(1:NSTEP,1))
    z(1:NSTEP)  =  invH * q(1:NSTEP)

    !! the second loop
    do i =  m, 1, -1
    beta(i) = rho(i) * dot_product(Dg(1:NSTEP,i), z(1:NSTEP))
    z(1:NSTEP) = z(1:NSTEP) + (alpha(i) -beta(i)) * Dm(1:NSTEP,i)
    enddo

    !! restart L-BFGS
    if ( dot_product(g_new(1:NSTEP), -z(1:NSTEP)) &
        / dot_product(g_new(1:NSTEP), g_new(1:NSTEP)) > 0.0 ) then
        print*, 'restarting L-BFGS ... [not the descent direction]'
        p_new(1:NSTEP) = - g_new(1:NSTEP)
        BFGS_step = 1
    else
        !! L-BFGS search direction
        p_new(1:NSTEP) = - z(1:NSTEP)
        BFGS_step = BFGS_step+1
    endif

end subroutine LBFGS


*DECK POISTG
      SUBROUTINE POISTG (NPEROD, N, MPEROD, M, A, B, C, IDIMY, Y,
     +   IERROR, W)
C***BEGIN PROLOGUE  POISTG
C***PURPOSE  Solve a block tridiagonal system of linear equations
C            that results from a staggered grid finite difference
C            approximation to 2-D elliptic PDE's.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B4B
C***TYPE      SINGLE PRECISION (POISTG-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, TRIDIAGONAL
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine POISTG solves the linear system of equations
C
C       A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J)
C       + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J)
C
C       for I=1,2,...,M and J=1,2,...,N.
C
C     The indices I+1 and I-1 are evaluated modulo M, i.e.
C     X(0,J) = X(M,J) and X(M+1,J) = X(1,J), and X(I,0) may be equal to
C     X(I,1) or -X(I,1) and X(I,N+1) may be equal to X(I,N) or -X(I,N)
C     depending on an input parameter.
C
C
C     * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C             * * * * * *   On Input    * * * * * *
C
C   NPEROD
C     Indicates the values which X(I,0) and X(I,N+1) are assumed
C     to have.
C     = 1 If X(I,0) = -X(I,1) and X(I,N+1) = -X(I,N)
C     = 2 If X(I,0) = -X(I,1) and X(I,N+1) =  X(I,N)
C     = 3 If X(I,0) =  X(I,1) and X(I,N+1) =  X(I,N)
C     = 4 If X(I,0) =  X(I,1) and X(I,N+1) = -X(I,N)
C
C   N
C     The number of unknowns in the J-direction.  N must
C     be greater than 2.
C
C   MPEROD
C     = 0 If A(1) and C(M) are not zero
C     = 1 If A(1) = C(M) = 0
C
C   M
C     The number of unknowns in the I-direction.  M must
C     be greater than 2.
C
C   A,B,C
C     One-dimensional arrays of length M that specify the coefficients
C     in the linear equations given above.  If MPEROD = 0 the array
C     elements must not depend on the index I, but must be constant.
C     Specifically, the subroutine checks the following condition
C
C           A(I) = C(1)
C           B(I) = B(1)
C           C(I) = C(1)
C
C     for I = 1, 2, ..., M.
C
C   IDIMY
C     The row (or first) dimension of the two-dimensional array Y as
C     it appears in the program calling POISTG.  This parameter is
C     used to specify the variable dimension of Y.  IDIMY must be at
C     least M.
C
C   Y
C     A two-dimensional array that specifies the values of the
C     right side of the linear system of equations given above.
C     Y must be dimensioned at least M X N.
C
C   W
C     A one-dimensional work array that must be provided by the user
C     for work space.  W may require up to 9M + 4N + M(INT(log2(N)))
C     locations.  The actual number of locations used is computed by
C     POISTG and returned in location W(1).
C
C
C             * * * * * *   On Output     * * * * * *
C
C   Y
C     Contains the solution X.
C
C   IERROR
C     An error flag that indicates invalid input parameters.  Except
C     for number zero, a solution is not attempted.
C     = 0  No error
C     = 1  If M .LE. 2
C     = 2  If N .LE. 2
C     = 3  IDIMY .LT. M
C     = 4  If NPEROD .LT. 1 or NPEROD .GT. 4
C     = 5  If MPEROD .LT. 0 or MPEROD .GT. 1
C     = 6  If MPEROD = 0 and
C          A(I) .NE. C(1) or B(I) .NE. B(1) or C(I) .NE. C(1)
C          for some I = 1, 2, ..., M.
C       = 7 If MPEROD .EQ. 1 .AND. (A(1).NE.0 .OR. C(M).NE.0)
C
C   W
C     W(1) contains the required length of W.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   A(M),B(M),C(M),Y(IDIMY,N),
C     Arguments      W(see argument list)
C
C     Latest         June 1, 1977
C     Revision
C
C     Subprograms    POISTG,POSTG2,COSGEN,MERGE,TRIX,TRI3,PIMACH
C     Required
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Written by Roland Sweet in 1973
C                    Revised by Roland Sweet in 1977
C
C
C     Space          3297(decimal) = 6341(octal) locations on the
C     Required       NCAR Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine POISTG is roughly proportional
C                    to M*N*log2(N).  Some typical values are listed
C                    in the table below.  More comprehensive timing
C                    charts may be found in the reference.
C                       To measure the accuracy of the algorithm a
C                    uniform random number generator was used to create
C                    a solution array X for the system given in the
C                    'PURPOSE ' with
C
C                       A(I) = C(I) = -0.5*B(I) = 1,       I=1,2,...,M
C
C                    and, when MPEROD = 1
C
C                       A(1) = C(M) = 0
C                       B(1) = B(M) =-1.
C
C                    The solution X was substituted into the given sys-
C                    tem and, using double precision, a right side Y was
C                    computed.  Using this array Y subroutine POISTG was
C                    called to produce an approximate solution Z.  Then
C                    the relative error, defined as
C
C                       E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J)))
C
C                    where the two maxima are taken over all I=1,2,...,M
C                    and J=1,2,...,N, was computed.  The value of E is
C                    given in the table below for some typical values of
C                    M and N.
C
C
C                       M (=N)    MPEROD    NPEROD    T(MSECS)    E
C                       ------    ------    ------    --------  ------
C
C                         31        0-1       1-4        45     9.E-13
C                         31        1         1          21     4.E-13
C                         31        1         3          41     3.E-13
C                         32        0-1       1-4        51     3.E-12
C                         32        1         1          32     3.E-13
C                         32        1         3          48     1.E-13
C                         33        0-1       1-4        42     1.E-12
C                         33        1         1          30     4.E-13
C                         33        1         3          34     1.E-13
C                         63        0-1       1-4       186     3.E-12
C                         63        1         1          91     1.E-12
C                         63        1         3         173     2.E-13
C                         64        0-1       1-4       209     4.E-12
C                         64        1         1         128     1.E-12
C                         64        1         3         199     6.E-13
C                         65        0-1       1-4       143     2.E-13
C                         65        1         1         160     1.E-11
C                         65        1         3         138     4.E-13
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       COS
C     Resident
C     Routines
C
C     Reference      Schumann, U. and R. Sweet,'A Direct Method for
C                    the Solution of Poisson's Equation With Neumann
C                    Boundary Conditions on a Staggered Grid of
C                    Arbitrary Size,' J. Comp. Phys. 20(1976),
C                    pp. 171-182.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  U. Schumann and R. Sweet, A direct method for the
C                 solution of Poisson's equation with Neumann boundary
C                 conditions on a staggered grid of arbitrary size,
C                 Journal of Computational Physics 20, (1976),
C                 pp. 171-182.
C***ROUTINES CALLED  POSTG2
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  POISTG
C
C
      DIMENSION       Y(IDIMY,*)
      DIMENSION       W(*)       ,B(*)       ,A(*)       ,C(*)
C***FIRST EXECUTABLE STATEMENT  POISTG
      IERROR = 0
      IF (M .LE. 2) IERROR = 1
      IF (N .LE. 2) IERROR = 2
      IF (IDIMY .LT. M) IERROR = 3
      IF (NPEROD.LT.1 .OR. NPEROD.GT.4) IERROR = 4
      IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5
      IF (MPEROD .EQ. 1) GO TO 103
      DO 101 I=1,M
         IF (A(I) .NE. C(1)) GO TO 102
         IF (C(I) .NE. C(1)) GO TO 102
         IF (B(I) .NE. B(1)) GO TO 102
  101 CONTINUE
      GO TO 104
  102 IERROR = 6
      RETURN
  103 IF (A(1).NE.0. .OR. C(M).NE.0.) IERROR = 7
  104 IF (IERROR .NE. 0) RETURN
      IWBA = M+1
      IWBB = IWBA+M
      IWBC = IWBB+M
      IWB2 = IWBC+M
      IWB3 = IWB2+M
      IWW1 = IWB3+M
      IWW2 = IWW1+M
      IWW3 = IWW2+M
      IWD = IWW3+M
      IWTCOS = IWD+M
      IWP = IWTCOS+4*N
      DO 106 I=1,M
         K = IWBA+I-1
         W(K) = -A(I)
         K = IWBC+I-1
         W(K) = -C(I)
         K = IWBB+I-1
         W(K) = 2.-B(I)
         DO 105 J=1,N
            Y(I,J) = -Y(I,J)
  105    CONTINUE
  106 CONTINUE
      NP = NPEROD
      MP = MPEROD+1
      GO TO (110,107),MP
  107 CONTINUE
      GO TO (108,108,108,119),NPEROD
  108 CONTINUE
      CALL POSTG2 (NP,N,M,W(IWBA),W(IWBB),W(IWBC),IDIMY,Y,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
      IPSTOR = W(IWW1)
      IREV = 2
      IF (NPEROD .EQ. 4) GO TO 120
  109 CONTINUE
      GO TO (123,129),MP
  110 CONTINUE
C
C     REORDER UNKNOWNS WHEN MP =0
C
      MH = (M+1)/2
      MHM1 = MH-1
      MODD = 1
      IF (MH*2 .EQ. M) MODD = 2
      DO 115 J=1,N
         DO 111 I=1,MHM1
            MHPI = MH+I
            MHMI = MH-I
            W(I) = Y(MHMI,J)-Y(MHPI,J)
            W(MHPI) = Y(MHMI,J)+Y(MHPI,J)
  111    CONTINUE
         W(MH) = 2.*Y(MH,J)
         GO TO (113,112),MODD
  112    W(M) = 2.*Y(M,J)
  113    CONTINUE
         DO 114 I=1,M
            Y(I,J) = W(I)
  114    CONTINUE
  115 CONTINUE
      K = IWBC+MHM1-1
      I = IWBA+MHM1
      W(K) = 0.
      W(I) = 0.
      W(K+1) = 2.*W(K+1)
      GO TO (116,117),MODD
  116 CONTINUE
      K = IWBB+MHM1-1
      W(K) = W(K)-W(I-1)
      W(IWBC-1) = W(IWBC-1)+W(IWBB-1)
      GO TO 118
  117 W(IWBB-1) = W(K+1)
  118 CONTINUE
      GO TO 107
  119 CONTINUE
C
C     REVERSE COLUMNS WHEN NPEROD = 4.
C
      IREV = 1
      NBY2 = N/2
      NP = 2
  120 DO 122 J=1,NBY2
         MSKIP = N+1-J
         DO 121 I=1,M
            A1 = Y(I,J)
            Y(I,J) = Y(I,MSKIP)
            Y(I,MSKIP) = A1
  121    CONTINUE
  122 CONTINUE
      GO TO (108,109),IREV
  123 CONTINUE
      DO 128 J=1,N
         DO 124 I=1,MHM1
            MHMI = MH-I
            MHPI = MH+I
            W(MHMI) = .5*(Y(MHPI,J)+Y(I,J))
            W(MHPI) = .5*(Y(MHPI,J)-Y(I,J))
  124    CONTINUE
         W(MH) = .5*Y(MH,J)
         GO TO (126,125),MODD
  125    W(M) = .5*Y(M,J)
  126    CONTINUE
         DO 127 I=1,M
            Y(I,J) = W(I)
  127    CONTINUE
  128 CONTINUE
  129 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR W ARRAY.
C
      W(1) = IPSTOR+IWP-1
      RETURN
      END


A(1, 1) = -4*H**3*alpha*sqrt(cgs_graw)*pi*r**(-1.5d0)*rho*sqrt(sol_mass) &
      /(m_bh*sol_rschw**(3.0d0/2.0d0)) + m_bh*m_dot*sol_mdot_edd*( &
      -1.73205080756888d0*r**(-0.5d0) + 1)
A(2, 1) = -9.0d0/16.0d0*H**4*alpha*cgs_graw**(3.0d0/2.0d0)*r**(-4.5d0)* &
      rho**2*sol_mass**(3.0d0/2.0d0)*(kappa_es + kappa_abs_0*rho/T**(7.0d0/ &
      2.0d0))/(m_bh**3*sol_rschw**(9.0d0/2.0d0)) + 4*T**4*cgs_stef
A(3, 1) = H**2*cgs_graw*r**(-3.0d0)*rho*sol_mass/(m_bh**2*sol_rschw**3) &
      - 4.0d0/3.0d0*T**4*cgs_stef/cgs_c - 2*T*cgs_boltz*rho/cgs_mhydr
M(1, 1) = 4*H**3*alpha*sqrt(cgs_graw)*pi*r**(-1.5d0)*sqrt(sol_mass)/( &
      m_bh*sol_rschw**(3.0d0/2.0d0))
M(2, 1) = (9.0d0/8.0d0)*H**4*alpha*cgs_graw**(3.0d0/2.0d0)*r**(-4.5d0)* &
      rho*sol_mass**(3.0d0/2.0d0)*(kappa_es + kappa_abs_0*rho/T**(7.0d0/ &
      2.0d0))/(m_bh**3*sol_rschw**(9.0d0/2.0d0)) + (9.0d0/16.0d0)*H**4* &
      alpha*cgs_graw**(3.0d0/2.0d0)*kappa_abs_0*r**(-4.5d0)*rho**2* &
      sol_mass**(3.0d0/2.0d0)/(T**(7.0d0/2.0d0)*m_bh**3*sol_rschw**( &
      9.0d0/2.0d0))
M(3, 1) = -H**2*cgs_graw*r**(-3.0d0)*sol_mass/(m_bh**2*sol_rschw**3) + 2 &
      *T*cgs_boltz/cgs_mhydr
M(1, 2) = 0
M(2, 2) = -63.0d0/32.0d0*H**4*alpha*cgs_graw**(3.0d0/2.0d0)*kappa_abs_0*r** &
      (-4.5d0)*rho**3*sol_mass**(3.0d0/2.0d0)/(T**(9.0d0/2.0d0)*m_bh**3 &
      *sol_rschw**(9.0d0/2.0d0)) - 16*T**3*cgs_stef
M(3, 2) = (16.0d0/3.0d0)*T**3*cgs_stef/cgs_c + 2*cgs_boltz*rho/cgs_mhydr
M(1, 3) = 12*H**2*alpha*sqrt(cgs_graw)*pi*r**(-1.5d0)*rho*sqrt(sol_mass) &
      /(m_bh*sol_rschw**(3.0d0/2.0d0))
M(2, 3) = (9.0d0/4.0d0)*H**3*alpha*cgs_graw**(3.0d0/2.0d0)*r**(-4.5d0)* &
      rho**2*sol_mass**(3.0d0/2.0d0)*(kappa_es + kappa_abs_0*rho/T**(7.0d0/ &
      2.0d0))/(m_bh**3*sol_rschw**(9.0d0/2.0d0))
M(3, 3) = -2*H*cgs_graw*r**(-3.0d0)*rho*sol_mass/(m_bh**2*sol_rschw**3)


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2020 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.
!
!     calculate the maximal admissible pressure ratio pt2/pt1
!
!     1) for icase=1 (sonic conditions are possible at 1):
!                    assuming M1=1 M2 is calculated iteratively
!                    using a dichotomy scheme
!        for icase=2 (sonic conditions are possible at 2):
!                    assuming M2=1 M1 is calculated iteratively
!                    using a dichotomy scheme
!
!     2)the ratio of the critical pressure ratio
!       Qred_1/Qred_2crit=Pt2/Pt1=D(M1)/D(M2_crit)
!       is computed
!       [D(M)=M*(1+0.5*(kappa-1)*M)**(-0.5*(kappa+1)/(kappa-1))]
!       (general gas equation)
!
!     author: Yannick Muller/Guido Dhondt
!
!     Attention: this routine is only used for rotating gas pipes
!                with rotational speed 0, i.e. static pipes with a possibly
!                varying cross section. In such pipes the total pressure
!                always decreases versus length in flow direction
!                beta > 0: flow from node1 to node2
!                beta < 0: flow from node2 to node1
!
      subroutine pt2zpt1_rot(pt2,pt1,kappa,r,l,pt2zpt1_c,crit,icase,
     &     M1,M2,ca,cb,cc,alpha,beta,Qred1_crit,Qred2_crit,A1,A2)
!
      implicit none
!
      logical crit
!
      integer icase,i
!
      real*8 pt2,pt1,kappa,l,M1,pt2zpt1,pt2zpt1_c,km1,kp1,r,Qred1_crit,
     &     fmin,Qred2_crit,f,fmax,M1_min,M1_max,Z1,Z1_min,Z1_max,Z2,
     &     Z2_min,Z2_max,M2,M2_min,M2_max,tcdkm1,km1d2,ca,cb,cc,alpha,
     &     beta,A1,A2,M1_root,M2_root
!
!
!
      crit=.false.
!
!     useful variables and constants
!
      km1=kappa-1.d0
      kp1=kappa+1.d0
      km1d2=km1/2.d0
      tcdkm1=2.d0*cc/(kappa-1.d0)
!
      if(icase.eq.1) then
!
!        M1=1
!        computing M2 using dichotomy method (dividing the interval
!        with the funciton root iteratively by 2)
!
         i=1
!
!        because of
!        (alpha+beta*Z2_min)/(alpha+beta))**(cb/beta)
!        we have to avoid a root in the initial dichotomy interval
!
!        for icase.eq.1 we have:
!     alpha+beta*Z is somewhere in the interval [0,1] negative;
!
!        if beta >= 0, alpha<0 must be true;
!        since alpha+beta*Z is monotonically increasing, a root in the
!        interval is only possible for alpha+beta>0
!
!        if beta <= 0, alpha+beta<0 must be true;
!        since alpha+beta*Z is monotonically decreasing, a root in the
!        interval is only possible for alpha>0
!
         if(beta.ge.0.d0) then
            if(alpha+beta.gt.0.d0) then
               M2_root=dsqrt(-alpha/beta)
               M2_min=max(0.001d0,M2_root+0.001d0)
               M2_max=0.999d0
            else
               M2_min=0.001d0
               M2_max=0.999d0
            endif
         else
            if(alpha.gt.0.d0) then
               M2_root=dsqrt(-alpha/beta)
               M2_min=max(0.001d0,M2_root+0.001d0)
               M2_max=0.999d0
            else
               M2_min=0.001d0
               M2_max=0.999d0
            endif
         endif

c         M2_min=0.001d0
c         M2_max=1
         Z2_min=M2_min**2
         Z2_max=M2_max**2
!
         fmin=dlog(Z2_min**ca*
     &        ((alpha+beta*Z2_min)/(alpha+beta))**(cb/beta)*
     &        ((1.d0+km1d2*Z2_min)/(1.d0+km1d2))**(tcdkm1))-l
!
         fmax=dlog(Z2_max**ca*
     &        ((alpha+beta*Z2_max)/(alpha+beta))**(cb/beta)*
     &        ((1.d0+km1d2*Z2_max)/(1.d0+km1d2))**(tcdkm1))-l
!
         if(fmin*fmax.gt.0.d0) then
            pt2zpt1_c=1.d30
            Qred2_crit=1.d30
            crit=.false.
            return
         endif
!
         do
            i=i+1
            M2=(M2_min+M2_max)*0.5d0
            Z2=M2**2
!
            f=dlog(Z2**ca*
     &           ((alpha+beta*Z2)/(alpha+beta))**(cb/beta)*
     &           ((1.d0+km1d2*Z2)/(1.d0+km1d2))**(tcdkm1))-l
!
            if(abs(f).le.1d-6) then
               exit
            endif
            if(i.gt.50) then
               exit
            endif
!
            if(fmin*f.le.0.d0) then
               M2_max=M2
               fmax=f
            else
               M2_min=M2
               fmin=f
            endif
         enddo
         write(*,*) 'pt2zpt1_rot M2 ',M2
!
         pt2zpt1_c=(0.5d0*kp1)**(-0.5d0*kp1/km1)
     &        *(1.d0+0.5d0*km1*Z2)**(0.5d0*kp1/km1)*A1/(A2*M2)
!
         Qred2_crit=M2*dsqrt(kappa/r)
     &        *(1.d0+0.5d0*km1*Z2)**(-0.5d0*kp1/km1)
!
         pt2zpt1=pt2/pt1
         write(*,*) 'pt2zpt1_rot pt2/pt1 ',pt2zpt1_c,pt2zpt1
         if(beta.ge.0.d0) then
            if(pt2zpt1.le.pt2zpt1_c) then
               crit=.true.
            endif
         else
            if(pt2zpt1.ge.pt2zpt1_c) then
               crit=.true.
            endif
         endif
!
      elseif (icase.eq.2) then
!
!        M2=1
!        computing M1 using dichotomy method (dividing the interval
!        with the function root iteratively by 2)
!
         i=1
!
!        because of
!        (alpha+beta*Z2_min)/(alpha+beta))**(cb/beta)
!        we have to avoid a root in the initial dichotomy interval
!
!        for icase.eq.2 we have:
!     alpha+beta*Z is somewhere in the interval [0,1] positive;

!        if beta >= 0 alpha+beta*Z is monotonically increasing, and a root
!        in the interval is only possible for alpha<0

!        if beta <= 0 alpha+beta*Z is monotonically decreasing, and a root
!        in the interval is only possible for alpha+beta<0
!
!
         if(beta.ge.0.d0) then
            if(alpha.lt.0.d0) then
               M1_root=dsqrt(-alpha/beta)
               M1_min=max(0.001d0,M1_root+0.001d0)
               M1_max=0.999d0
            else
               M1_min=0.001d0
               M1_max=0.999d0
            endif
         else
            if(alpha+beta.lt.0.d0) then
               M1_root=dsqrt(-alpha/beta)
               M1_min=max(0.001d0,M1_root+0.001d0)
               M1_max=0.999d0
            else
               M1_min=0.001d0
               M1_max=0.999d0
            endif
         endif
c         M1_min=0.001d0
c         M1_max=1
         Z1_min=M1_min**2
         Z1_max=M1_max**2
!
         fmin=dlog((1.d0/Z1_min)**ca*
     &        ((alpha+beta)/(alpha+beta*Z1_min))**(cb/beta)*
     &        ((1.d0+km1d2)/(1.d0+km1d2*Z1_min))**(tcdkm1))-l
!
         fmax=dlog((1.d0/Z1_max)**ca*
     &        ((alpha+beta)/(alpha+beta*Z1_max))**(cb/beta)*
     &        ((1.d0+km1d2)/(1.d0+km1d2*Z1_max))**(tcdkm1))-l
!
         if(fmin*fmax.gt.0.d0) then
            pt2zpt1_c=1.d30
            Qred1_crit=1.d30
            crit=.false.
            return
         endif
!
         do
            i=i+1
            M1=(M1_min+M1_max)*0.5d0
            Z1=M1**2
!
            f=dlog((1.d0/Z1)**ca*
     &           ((alpha+beta)/(alpha+beta*Z1))**(cb/beta)*
     &           ((1.d0+km1d2)/(1.d0+km1d2*Z1))**(tcdkm1))-l
!
            if(abs(f).le.1d-6) then
               exit
            endif
            if(i.gt.50) then
               exit
            endif
!
            if(fmin*f.le.0.d0) then
               M1_max=M1
               fmax=f
            else
               M1_min=M1
               fmin=f
            endif
         enddo
!
         pt2zpt1_c=M1*(0.5d0*kp1)**(0.5d0*kp1/km1)
     &        *(1.d0+0.5d0*km1*Z1)**(-0.5d0*kp1/km1)*A1/A2
!
         Qred1_crit=M1*dsqrt(kappa/r)
     &        *(1.d0+0.5d0*km1*Z1)**(-0.5d0*kp1/km1)
!
         pt2zpt1=pt2/pt1
         if(beta.ge.0.d0) then
            if(pt2zpt1.le.pt2zpt1_c) then
               crit=.true.
            endif
         else
            if(pt2zpt1.ge.pt2zpt1_c) then
               crit=.true.
            endif
         endif
!
      endif
!
      return
      end


      SUBROUTINE TF01MX( N, M, P, NY, S, LDS, U, LDU, X, Y, LDY,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the output sequence of a linear time-invariant
C     open-loop system given by its discrete-time state-space model
C     with an (N+P)-by-(N+M) general system matrix S,
C
C            ( A  B )
C        S = (      ) .
C            ( C  D )
C
C     The initial state vector x(1) must be supplied by the user.
C
C     The input and output trajectories are stored as in the SLICOT
C     Library routine TF01MY.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     NY      (input) INTEGER
C             The number of output vectors y(k) to be computed.
C             NY >= 0.
C
C     S       (input) DOUBLE PRECISION array, dimension (LDS,N+M)
C             The leading (N+P)-by-(N+M) part of this array must contain
C             the system matrix S.
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,N+P).
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU,M)
C             The leading NY-by-M part of this array must contain the
C             input vector sequence u(k), for k = 1,2,...,NY.
C             Specifically, the k-th row of U must contain u(k)'.
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= MAX(1,NY).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the initial state vector
C             x(1) which consists of the N initial states of the system.
C             On exit, this array contains the final state vector
C             x(NY+1) of the N states of the system at instant NY+1.
C
C     Y       (output) DOUBLE PRECISION array, dimension (LDY,P)
C             The leading NY-by-P part of this array contains the output
C             vector sequence y(1),y(2),...,y(NY) such that the k-th
C             row of Y contains y(k)' (the outputs at instant k),
C             for k = 1,2,...,NY.
C
C     LDY     INTEGER
C             The leading dimension of array Y.  LDY >= MAX(1,NY).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 0,        if MIN(N,P,NY) = 0;  otherwise,
C             LDWORK >= N+P,      if M = 0;
C             LDWORK >= 2*N+M+P,  if M > 0.
C             For better performance, LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Given an initial state vector x(1), the output vector sequence
C     y(1), y(2),..., y(NY) is obtained via the formulae
C
C        ( x(k+1) )     ( x(k) )
C        (        ) = S (      ) ,
C        (  y(k)  )     ( u(k) )
C
C     where each element y(k) is a vector of length P containing the
C     outputs at instant k, and k = 1,2,...,NY.
C
C     REFERENCES
C
C     [1] Luenberger, D.G.
C         Introduction to Dynamic Systems: Theory, Models and
C         Applications.
C         John Wiley & Sons, New York, 1979.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately (N + M) x (N + P) x NY
C     multiplications and additions.
C
C     FURTHER COMMENTS
C
C     The implementation exploits data locality as much as possible,
C     given the workspace length.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 2002.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Discrete-time system, multivariable system, state-space model,
C     state-space representation, time response.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDS, LDU, LDWORK, LDY, M, N, NY, P
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), S(LDS,*), U(LDU,*), X(*), Y(LDY,*)
C     .. Local Scalars ..
      INTEGER           I, IC, IU, IW, IY, J, JW, K, N2M, N2P, NB, NF,
     $                  NM, NP, NS
C     .. External Functions ..
      INTEGER           ILAENV
      EXTERNAL          ILAENV
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DLASET, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      NP = N  + P
      NM = N  + M
      IW = NM + NP
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( NY.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDS.LT.MAX( 1, NP ) ) THEN
         INFO = -6
      ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN
         INFO = -8
      ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN
         INFO = -11
      ELSE
         IF( MIN( N, P, NY ).EQ.0 ) THEN
            JW = 0
         ELSE IF( M.EQ.0 ) THEN
            JW = NP
         ELSE
            JW = IW
         END IF
         IF( LDWORK.LT.JW )
     $      INFO = -13
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TF01MX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( NY, P ).EQ.0 ) THEN
         RETURN
      ELSE IF ( N.EQ.0 ) THEN
C
C        Non-dynamic system: compute the output vectors.
C
         IF ( M.EQ.0 ) THEN
            CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY )
         ELSE
            CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE,
     $                  U, LDU, S, LDS, ZERO, Y, LDY )
         END IF
         RETURN
      END IF
C
C     Determine the block size (taken as for LAPACK routine DGETRF).
C
      NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 )
C
C     Find the number of state vectors, extended with inputs (if M > 0)
C     and outputs, that can be accommodated in the provided workspace.
C
      NS  = MIN( LDWORK/JW, NB*NB/JW, NY )
      N2P = N + NP
C
      IF ( M.EQ.0 ) THEN
C
C        System with no inputs.
C        Workspace: need   N + P;
C                   prefer larger.
C
         IF( NS.LE.1 .OR. NY*P.LE.NB*NB ) THEN
            IY = N + 1
C
C           LDWORK < 2*(N+P), or small problem.
C           One row of array Y is computed for each loop index value.
C
            DO 10 I = 1, NY
C
C              Compute
C
C              /x(i+1)\    /A\
C              |      | =  | | * x(i).
C              \ y(i) /    \C/
C
               CALL DGEMV( 'NoTranspose', NP, N, ONE, S, LDS, X, 1,
     $                     ZERO, DWORK, 1 )
               CALL DCOPY( N, DWORK, 1, X, 1 )
               CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY )
   10       CONTINUE
C
         ELSE
C
C           LDWORK >= 2*(N+P), and large problem.
C           NS rows of array Y are computed before being saved.
C
            NF = ( NY/NS )*NS
            CALL DCOPY( N, X, 1, DWORK, 1 )
C
            DO 40 I = 1, NF, NS
C
C              Compute the current NS extended state vectors in the
C              workspace:
C
C              /x(i+1)\    /A\
C              |      | =  | | * x(i),  i = 1 : ns - 1.
C              \ y(i) /    \C/
C
               DO 20 IC = 1, ( NS - 1 )*NP, NP
                  CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS,
     $                        DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 )
   20          CONTINUE
C
C              Prepare the next iteration.
C
               CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS,
     $                     DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 )
C
C              Transpose the NS output vectors in the corresponding part
C              of Y (column-wise).
C
               DO 30 J = 1, P
                  CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(I,J), 1 )
                  Y(I+NS-1,J) = DWORK(N+J)
   30          CONTINUE
C
   40       CONTINUE
C
            NS = NY - NF
C
            IF ( NS.GT.1 ) THEN
C
C              Compute similarly the last NS output vectors.
C
               DO 50 IC = 1, ( NS - 1 )*NP, NP
                  CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS,
     $                        DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 )
   50          CONTINUE
C
               CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS,
     $                     DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 )
C
               DO 60 J = 1, P
                  CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(NF+1,J), 1 )
                  Y(NF+NS,J) = DWORK(N+J)
   60          CONTINUE
C
            ELSE IF ( NS.EQ.1 ) THEN
C
C              Compute similarly the last NS = 1 output vectors.
C
               CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 )
               CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS,
     $                     DWORK(NP+1), 1, ZERO, DWORK, 1 )
               CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY )
C
            END IF
C
C           Set the final state vector.
C
            CALL DCOPY( N, DWORK, 1, X, 1 )
C
         END IF
C
      ELSE
C
C        General case.
C        Workspace: need   2*N + M + P;
C                   prefer larger.
C
         CALL DCOPY( N, X, 1, DWORK, 1 )
C
         IF( NS.LE.1 .OR. NY*( M + P ).LE.NB*NB ) THEN
            IU = N  + 1
            JW = IU + M
            IY = JW + N
C
C           LDWORK < 2*(2*N+M+P), or small problem.
C           One row of array Y is computed for each loop index value.
C
            DO 70 I = 1, NY
C
C              Compute
C
C              /x(i+1)\    /A, B\   /x(i)\
C              |      | =  |    | * |    | .
C              \ y(i) /    \C, D/   \u(i)/
C
               CALL DCOPY( M, U(I,1), LDU, DWORK(IU), 1 )
               CALL DGEMV( 'NoTranspose', NP, NM, ONE, S, LDS, DWORK, 1,
     $                     ZERO, DWORK(JW), 1 )
               CALL DCOPY( N, DWORK(JW), 1, DWORK, 1 )
               CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY )
   70       CONTINUE
C
         ELSE
C
C           LDWORK >= 2*(2*N+M+P), and large problem.
C           NS rows of array Y are computed before being saved.
C
            NF  = ( NY/NS )*NS
            N2M = N + NM
C
            DO 110 I = 1, NF, NS
               JW = 1
C
C              Compute the current NS extended state vectors in the
C              workspace:
C
C              /x(i+1)\    /A, B\   /x(i)\
C              |      | =  |    | * |    | ,  i = 1 : ns - 1.
C              \ y(i) /    \C, D/   \u(i)/
C
               DO 80 J = 1, M
                  CALL DCOPY( NS, U(I,J), 1, DWORK(N+J), IW )
   80          CONTINUE
C
               DO 90 K = 1, NS - 1
                  CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS,
     $                        DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 )
                  JW = JW + NM
                  CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 )
                  JW = JW + NP
   90          CONTINUE
C
C              Prepare the next iteration.
C
               CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS,
     $                     DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 )
               CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 )
C
C              Transpose the NS output vectors in the corresponding part
C              of Y (column-wise).
C
               DO 100 J = 1, P
                  CALL DCOPY( NS, DWORK(N2M+J), IW, Y(I,J), 1 )
  100          CONTINUE
C
  110       CONTINUE
C
            NS = NY - NF
C
            IF ( NS.GT.1 ) THEN
               JW = 1
C
C              Compute similarly the last NS output vectors.
C
               DO 120 J = 1, M
                  CALL DCOPY( NS, U(NF+1,J), 1, DWORK(N+J), IW )
  120          CONTINUE
C
               DO 130 K = 1, NS - 1
                  CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS,
     $                        DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 )
                  JW = JW + NM
                  CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 )
                  JW = JW + NP
  130          CONTINUE
C
               CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS,
     $                     DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 )
               CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 )
C
               DO 140 J = 1, P
                  CALL DCOPY( NS, DWORK(N2M+J), IW, Y(NF+1,J), 1 )
  140          CONTINUE
C
            ELSE IF ( NS.EQ.1 ) THEN
C
C              Compute similarly the last NS = 1 output vectors.
C
               CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 )
               CALL DCOPY( M, U(NF+1,1), LDU, DWORK(N2P+1), 1 )
               CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS,
     $                     DWORK(NP+1), 1, ZERO, DWORK, 1 )
               CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY )
C
            END IF
C
         END IF
C
C        Set the final state vector.
C
         CALL DCOPY( N, DWORK, 1, X, 1 )
C
      END IF
C
      RETURN
C *** Last line of TF01MX ***
      END


 MODULE WANG
   implicit none
   integer, parameter:: in=10,im=2,igen=5           !! 'in' is the number of species in each patch, 'im' is the number of patches in the metacommunity
   integer, parameter:: imn=im*in, npar=imn*(imn+3)+im**2,ifact=1  !! npar is the number of parameters, ifact gives number of community pairs
   INTEGER, PARAMETER :: mlyap=0,NEQ=(mlyap+1)*imn,niter=30000,ntrans=20000,ninic=2000,net_Tscl=1000000  !! ntrans is transient time, niter is iteration beyond transients
   real(kind=4), parameter:: d_max=14000.d0, a_max=1000.d0, xL=1.d0
   real(kind=4):: par(npar)

    CONTAINS

      SUBROUTINE DERIVS(NEQ,T,Y,YDOT)
        IMPLICIT NONE
        INTEGER, intent(in):: NEQ
        real(kind=4), intent(in):: T, Y(NEQ)
        real(kind=4), intent(out):: YDOT(NEQ)
        integer(kind=4)::i,j,iti,itj,kc,icptch,iflag
        real(kind=4):: cptsum,cdsum
        real(kind=4):: ar(imn),akc(imn),acpt(imn,imn),ad(imn),xadj(im,im) !! parameters

        !*************************
        kc=0; do i=1,imn                                       !!
                kc=kc+1; ar(i)=par(kc)                         !!
              enddo                                            !! maximal growth rates
!             write(*,24),ar; pause
              do i=1,imn                                       !!
                kc=kc+1; akc(i)=par(kc)                        !!
              enddo                                            !! carrying capacities
!            write(*,24) akc; pause
              acpt=0.0                                         !! competition initialization
              do i=1,imn; do j=1,imn                           !!
                kc=kc+1; acpt(i,j)=par(kc)                     !! competition terms
              enddo; enddo                                     !!
!              write(*,24) acpt; pause
              do i=1,imn                                       !!
                kc=kc+1; ad(i)=par(kc)                         !!
              enddo                                            !! dispersal terms
           !write(*,24),ad; pause
              do i=1,im
               do j=1,im
               kc=kc+1; xadj(i,j)=par(kc)
               enddo
              enddo
            !  print*,xadj
        !*************************
        do iti=1,imn

           cptsum=0.0                                                   !!
           do itj=1,imn                                                 !! competition summation
            cptsum=cptsum+acpt(iti,itj)*Y(itj)                          !!
           enddo                                                        !!

           cdsum=0.0                                                                            !!
           icptch=int(float(iti-1)/float(in))+1                                                 !!
           iflag=mod(iti,in); if(iflag==0) iflag=in                                             !!
           kc=0
           do itj=1,im                               !! dispersal
            if(itj/=icptch) then
              cdsum=cdsum+xadj(itj,icptch)*Y(iflag+(itj-1)*in)                 !!
            endif
           !if(itj/=icptch) write(*,24) dfloat(iti),dfloat(icptch),dfloat(iflag+(itj-1)*in),ad(iti); pause
           enddo

           if (sum(xadj(:,icptch))>0.00001d0) then
             cdsum=cdsum/sum(xadj(:,icptch))
            else
             cdsum=0.d0
            endif

            YDOT(iti)=ar(iti)*Y(iti)*(1.0-(Y(iti)+cptsum)/akc(iti))+ad(iti)*(cdsum-Y(iti))

       enddo
       24  Format(30F15.7)
      RETURN
      END SUBROUTINE DERIVS
    END MODULE WANG

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

    PROGRAM DEMOWANG

      USE WANG
      USE random
!     Type declarations:
      IMPLICIT NONE
      real(kind=4):: h,T,TOUT, xrho1, xrho2, xvar1, xvar2, kppa
      real(kind=4):: ald,aldi,gmd,gmdi,btd, reg_avg
      real(kind=4):: alcv,gmcv,btcv
      real(kind=4):: sum_patch_l,svsum,spsum,tot_mean
      real(kind=4):: p_waxmn, p_mc
      integer(kind=4):: inic,IOUT,i,ii,j,jj,l,kcout,kij
      real(kind=4),allocatable:: Y(:),YDER(:),ctmp(:,:), noi_spec(:), noi_ptch(:), ypopl(:,:)
      real(kind=4),allocatable:: yavg(:,:),yprel(:,:),ysave(:,:,:),lo_simp(:), omg(:), sysame(:)
      real(kind=4),allocatable:: ymean(:), ysd(:), ycov(:,:)
      real(kind=4),allocatable:: adjm(:,:), beta(:), dist_mat(:,:)
      real(kind=4),allocatable:: simp_conc(:),xp_i(:)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables for the random number generator
    INTEGER, ALLOCATABLE  :: ix(:), seed(:)

    REAL, ALLOCATABLE     :: xep(:), xptch(:), xmeanep(:), xmeanptch(:), covep(:), covptch(:), chol_fep(:), &
                            chol_fptch(:), xseed(:)

    INTEGER               :: nep, nptch, ndf, n_binom, k, kep, kptch, ier, pos1, pos2, which, iindx

    REAL                  :: average, stdvn, shape, a, b, mu, p, pop_mean, pop_sd,   &
                            one = 1.0, zero = 0.0, sk, two = 2.0, pcntile(9), &
                            middle, xmax, xmin, xtseed
    LOGICAL               :: first

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   allocate(Y(NEQ),YDER(NEQ),ctmp(imn,imn),noi_spec(imn),noi_ptch(imn)); par=0.0
   allocate(yavg(im,in), yprel(im,in),lo_simp(im),sysame(in),ysave(im,in,niter))
   allocate(ymean(im),ysd(im),ycov(im,im))
   allocate(simp_conc(im),omg(im),xp_i(in))
   allocate(adjm(im,im),beta(im),dist_mat(im,im))    !!!! NETWORK PARAMETERS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! RANDOM NUMBER GENERATOR PREPARATION
!     Set the random number seed.
 CALL RANDOM_SEED(size=k)
 ALLOCATE (seed(k),xseed(k))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FIXING THE SEED
!do i=1,k; call cpu_time(xtseed); xseed(i)=xtseed; enddo
 call random_number(xseed)
 seed=int(50000*xseed)
 CALL RANDOM_SEED(put=seed)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!! STOCHASTIC PARAMETERS FROM PAPER
xrho1=0.0  !!print*, "Between species correlation";
!xrho2=0.0
read*,xrho2; print*, xrho2, "started" !! between patch correlation
xvar1=0.04  !! species specific variance
xvar2=0.04  !! patch specific variance
kppa=8.0    !! kappa

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! allocation for the random number for species specific environmental response
    kep=in                    !! species/patch
    nep = kep*(kep+1)/2
    ALLOCATE( xep(kep), xmeanep(kep), covep(nep), chol_fep(nep))

!!!!!! MEAN VECTOR
    xmeanep=0.0
! !
!!!!!! COVARIANCE MATRIX FOR SPECIES SPECIFIC ENVIRONMENTAL RESPONSE
        pos2 = 0
        DO i = 1, kep
         pos1 = pos2 + 1
         pos2 = pos2 + i
         covep(pos1:pos2)=xrho1*xvar1; covep(pos2)=xvar1
        END DO
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! allocation for the random number for patch specific environmental response
    kptch=im
    nptch = kptch*(kptch+1)/2
    ALLOCATE ( xptch(kptch), xmeanptch(kptch), covptch(nptch), chol_fptch(nptch) )
!!!!!! MEAN VECTOR FOR PATCHES
    xmeanptch=0.0
! !
!!!!!! COVARIANCE MATRIX FOR BETWEEN PATCH ENVIRONMENTAL RESPONSE
    pos2 = 0
    DO i = 1, kptch
        pos1 = pos2 + 1
        pos2 = pos2 + i
        covptch(pos1:pos2)=xrho2*xvar2; covptch(pos2)=xvar2
    END DO

    !!!!!!!!!!!!!!!!! NETWORK STUFF

       do i=1,im
         beta(i)=0.5d0!0.3d0+0.4d0*dfloat(i)/dfloat(NEQ)  ! AREA PROXIES for Waxman
       enddo

     dist_mat=0.d0
      do i=1,im
       do j=i+1,im
        call random_number(dist_mat(j,i)); dist_mat(i,j)=dist_mat(j,i)  !! dist_mat is the distance matrix for the KHs
        enddo
      enddo
      adjm=0.d0; kij=0; write(1,*) 'digraph {'
        do i=1,im                                      !
          do j=1,im
            kij=kij+1                                          !
            p_waxmn=(beta(i)*beta(j))*exp(-dist_mat(i,j)/xL)!(beta(i)*beta(j))*dexp(-dist_mat(i,j)/xL)  !
            call random_number(p_mc)                         ! Adjacency matrix
            !if(p_mc<p_waxmn) adjm(i,j)=1.d0
            adjm(i,j)=1.d0
            if(i==j) adjm(i,j)=0.d0                           !
            if(adjm(i,j)==1) write(1,*) i,'->',j!
          enddo                                              !
         enddo
         write(1,*) '}'

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! RANDOM NUMBER GEN. PREPARATION DONE
      do inic=1,ninic!; print*,inic
      par=0.0
!     Set  the problem parameters:
      call random_number(par(1:imn));
      par(1:imn)=0.5+par(1:imn)*1.0              !! M*N MAXIMAL GROWTH RATES

      call random_number(par(imn+1:2*imn))
      par(imn+1:2*imn)=0.5+par(imn+1:2*imn)*1.0  !! M*N CARRYING CAPACITIES
      ctmp=0.0
          do i=1,im
           call random_number(ctmp((i-1)*in+1:i*in,(i-1)*in+1:i*in))
           ctmp((i-1)*in+1:i*in,(i-1)*in+1:i*in)=0.25+ctmp((i-1)*in+1:i*in,(i-1)*in+1:i*in)*0.5
          if (i>1) ctmp((i-1)*in+1:i*in,(i-1)*in+1:i*in)=ctmp(1:in,1:in) !! weird addition following the Shaopeng supplied code - ask?
          enddo
          kcout=0
          do i=1,imn
           do j=1,imn
            kcout=kcout+1
            if(i==j) ctmp(i,j)=0.0
            par(2*imn+kcout)=ctmp(i,j)            !! (M*N)^2 COMPETITION COEFFICIENTS FOR M PATCHES
           enddo
          enddo
          !write(*,24)ctmp; pause
      do i=1,im
        call random_number(par(2*imn+imn**2+1+i*in-igen:2*imn+imn**2+i*in))                                         !! DISPERSAL RATES
       ! print*,par(2*imn+imn**2+1+i*in-igen:2*imn+imn**2+i*in)
        par(2*imn+imn**2+1+i*in-igen:2*imn+imn**2+i*in)=0.1+par(2*imn+imn**2+1+i*in-igen:2*imn+imn**2+i*in)*0.05         !!
        !print*,par(2*imn+imn**2+1+i*in-igen:2*imn+imn**2+i*in)
      enddo
      kcout=2*imn+imn**2+imn
      do i=1,im
        do j=1,im
         kcout=kcout+1; par(kcout)=adjm(i,j)
        enddo
      enddo
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !     Set the initial conditions:
       call random_number(Y); YDER=0.0
! !     Output points:
       T = 0.0
       h=0.01
! !     Perform the integration:
       DO IOUT = 1, ntrans
         call DERIVS(NEQ,T,Y,YDER)
         Y=Y+h*YDER
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        if(mod(IOUT,net_Tscl)==0) then  !! NETWORK RESET
         adjm=0.d0; kij=0 !! INITIALIZE ADJACENCY MATRIX
         do i=1,im                                                             !
          do j=1,im
            kij=kij+1                                                             !
            p_waxmn=(beta(i)*beta(j))*exp(-dist_mat(i,j)/xL)                   !
            call random_number(p_mc)                         ! Adjacency matrix
            !if(p_mc<p_waxmn) adjm(i,j)=1.d0                   !
            adjm(i,j)=1.d0
            if(i==j) adjm(i,j)=0.d0                           !
          enddo                                              !
         enddo
             kcout=2*imn+imn**2+imn
              do i=1,im
               do j=1,im
                kcout=kcout+1; par(kcout)=adjm(i,j)
               enddo
              enddo
       endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       T=T+h
       END DO ! IOUT
       Y=Y+0.1
  !!! TO TAKE CARE OF ZERO POPULATIONS
       first = .true.

       DO IOUT = 1, niter
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! EVOLUTION BEGINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! between species random number
        CALL random_mvnorm(kep, xmeanep, covep, chol_fep, first, xep, ier)
        IF (ier .NE. 0) THEN
            WRITE(*, *) '** Covariance matrix1 is not +ve definite **'
            PAUSE; !EXIT replaced since the do loop was removed
        END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! between patch random number
        CALL random_mvnorm(kptch, xmeanptch, covptch, chol_fptch, first, xptch, ier)
        IF (ier .NE. 0) THEN
        WRITE(*, *) '** Covariance matrix2 is not +ve definite **'
        PAUSE; !EXIT replaced since the do loop was removed
        END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        do i=1,im
           noi_spec((i-1)*in+1:i*in)=xep
        enddo         !!!!!!!!!!!!!noise arrangement for integration

        kcout=0
        do i=1,im
          do j=1,in
           kcout=kcout+1
           noi_ptch(kcout)=xptch(i)
          enddo
        enddo
         call DERIVS(NEQ,T,Y,YDER)
         do i=1,imn
           Y(i)=Y(i)+h*YDER(i)+sqrt(h)*Y(i)*(noi_spec(i)+noi_ptch(i) &
           & +kppa*noi_ptch(i)*noi_spec(i)) !!  noise added; T=T+h
         enddo
        kcout=0
        do l=1,im
         do i=1,in
           kcout=kcout+1
           ysave(l,i,IOUT)=Y(kcout)
          enddo
        enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        if(mod(IOUT,net_Tscl)==0) then  !! NETWORK RESET
         adjm=0.d0; kij=0 !! INITIALIZE ADJACENCY MATRIX
         do i=1,im                                                             !
          do j=1,im
            kij=kij+1                                                             !
            p_waxmn=(beta(i)*beta(j))*exp(-dist_mat(i,j)/xL)                   !
            call random_number(p_mc)                         ! Adjacency matrix
            !if(p_mc<p_waxmn) adjm(i,j)=1.d0                   !
            adjm(i,j)=1.d0
            if(i==j) adjm(i,j)=0.d0                           !
          enddo                                              !
         enddo
             kcout=2*imn+imn**2+imn
              do i=1,im
               do j=1,im
                kcout=kcout+1; par(kcout)=adjm(i,j)
               enddo
              enddo
       endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        T=T+h
       END DO ! IOUT
!!!!!!!!!!!!!!!!!!!!!!!! ENS based
   do l=1,im
     sum_patch_l=sum(ysave(l,:,niter))
    do i=1,in
     yprel(l,i)=ysave(l,i,niter)/sum_patch_l
    enddo
   enddo

  aldi=0.0
    do l=1,im
    simp_conc(l)=sum(yprel(l,:)**2)
    omg(l)=sum(ysave(l,:,niter))/sum(ysave(:,:,niter))
      aldi=aldi+omg(l)*simp_conc(l)
    enddo

    ald=1.0/aldi                              !! alpha_d

    do i=1,in
     xp_i(i)=sum(ysave(:,i,niter))/sum(ysave(:,:,niter))
    enddo

    gmdi=sum(xp_i**2) !! gamma_d inverse
    gmd=1.0/gmdi                                !! gamma_d
    btd=gmd/ald                                  !! beta_d

! !!!!! VARIABILITY BASED MEASURES!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      svsum=0.0
        do i=1,im        !!!! temporal mean for each patch
        spsum=0.0
         do IOUT=1,niter
          spsum=spsum+sum(ysave(i,:,IOUT))
         enddo
         ymean(i)=spsum/float(niter) !! temporal mean of community biomass in patch i
         svsum=svsum+ymean(i)
        enddo          !                                       QC done
        tot_mean=svsum!/float(niter)   ! temporal mean of metacommunity biomass
        reg_avg=tot_mean/float(im)    !regional average of temporal means of local community biomass

         ycov=0.d0
            do IOUT=1,niter
             do i=1,im
              do j=1,im
               ycov(i,j)=ycov(i,j)+(sum(ysave(i,:,IOUT))-ymean(i))*(sum(ysave(j,:,IOUT))-ymean(j))
              enddo
             enddo
            enddo
              ycov=ycov/float(niter)  !! covariance matrix between community biomasses
            do i=1,im
             ysd(i)=sqrt(ycov(i,i))
            enddo
      !      print*,ycov; pause
        alcv=(sum(ysd)/tot_mean)**2                  !! alpha_cv
        gmcv=sum(ycov)/(tot_mean)**2                 !! gamma_cv
        btcv=alcv/gmcv  !! is it correct?            !! beta_cv
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        write(11,24) ald, btd, gmd, alcv, btcv, gmcv
        write(*,24) ald, btd, gmd, alcv, btcv, gmcv
   enddo !!!! INIC
!! OUTPUT FILE FORMAT
      24  Format(20F20.7)

END PROGRAM DEMOWANG