module ellipticalintegrals
! Code written by VdVen. From numerical recipes (?).
use numeric_kinds
implicit none
private

  private :: rf, rd ! Carslon circular and elliptic functions
  public :: ellf, elle ! Legendre ellptic integrals

contains

  !!! Carlson's function R_F(x,y,z) !!!
  SUBROUTINE rf(x,y,z,res)
    REAL (kind=dp), intent(in) :: x,y,z
    REAL (kind=dp), intent(out) :: res
    REAL (kind=dp), parameter :: ERRTOL=0.08,TINY=1.5e-38,BIG=3.E37,THIRD=1.0/3.0,&
         C1=1.0/24.0,C2=0.1,C3=3.0/44.0,C4=1.0/14.0
    REAL (kind=dp) :: alamb,ave,delx,dely,delz,e2,e3,sqrtx,sqrty,sqrtz,xt,yt,zt
    if(min(x,y,z) < 0.0.or.min(x+y,x+z,y+z) < TINY.or.max(x,y,z) > BIG)&
         stop "invalid arguments in rf"
    xt=x
    yt=y
    zt=z
    do
    sqrtx=sqrt(xt)
    sqrty=sqrt(yt)
    sqrtz=sqrt(zt)
    alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
    xt=0.25*(xt+alamb)
    yt=0.25*(yt+alamb)
    zt=0.25*(zt+alamb)
    ave=THIRD*(xt+yt+zt)
    delx=(ave-xt)/ave
    dely=(ave-yt)/ave
    delz=(ave-zt)/ave
    if(max(abs(delx),abs(dely),abs(delz)) <= ERRTOL) exit
    end do
    e2=delx*dely-delz**2
    e3=delx*dely*delz
    res=(1.0+(C1*e2-C2-C3*e3)*e2+C4*e3)/sqrt(ave)
  END SUBROUTINE rf

  !!! Carlson's function R_D(x,y,z) !!!
  SUBROUTINE rd(x,y,z,res)
    REAL (kind=dp), intent(in) :: x,y,z
    REAL (kind=dp), intent(out) :: res
    REAL (kind=dp), parameter :: ERRTOL=0.05,TINY=1.5e-25,BIG=4.5E21,&
         C1=3.0/14.0,C2=1.0/6.0,C3=9.0/22.0,C4=3.0/26.0,C5=0.25*C3,C6=1.5*C4
    REAL (kind=dp) :: alamb,ave,delx,dely,delz,ea,eb,ec,ed,ee,fac,&
         sqrtx,sqrty,sqrtz,sum,xt,yt,zt
    if(min(x,y) < 0.0.or.min(x+y,z) < TINY.or.max(x,y,z) > BIG)&
         stop "invalid arguments in rd"
    xt=x
    yt=y
    zt=z
    sum=0.0
    fac=1.0
    do
       sqrtx=sqrt(xt)
       sqrty=sqrt(yt)
       sqrtz=sqrt(zt)
       alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
       sum=sum+fac/(sqrtz*(zt+alamb))
       fac=0.25*fac
       xt=0.25*(xt+alamb)
       yt=0.25*(yt+alamb)
       zt=0.25*(zt+alamb)
       ave=0.2*(xt+yt+3.0*zt)
       delx=(ave-xt)/ave
       dely=(ave-yt)/ave
       delz=(ave-zt)/ave
       if(max(abs(delx),abs(dely),abs(delz)) <= ERRTOL) exit
    end do
    ea=delx*dely
    eb=delz*delz
    ec=ea-eb
    ed=ea-6.0*eb
    ee=ed+ec+ec
    res=3.0*sum+fac*(1.0+ed*(-C1+C5*ed-C6*delz*ee)+delz*(C2*ee+delz*(-C3*&
         ec+delz*C4*ea)))/(ave*sqrt(ave))
  END SUBROUTINE rd

  SUBROUTINE ellf(pp,kk,res)
    REAL (kind=dp), intent(in) :: pp,kk
    REAL (kind=dp), intent(out) :: res
    REAL (kind=dp) :: s,dum
    s=sin(pp)
    call rf(cos(pp)**2,(1.0-s*kk)*(1.0+s*kk),1.0_dp,dum)
    res=s*dum
  END SUBROUTINE ellf

  !!! elliptic integral of the second kind !!!
  !!! Def.: E(phi,k) = int(sqrt(1-k^2*sin^2theta),0..phi) !!!
  SUBROUTINE elle(pp,kk,res)
    REAL (kind=dp), intent(in) :: kk,pp
    REAL (kind=dp), intent(out) :: res
    REAL (kind=dp) :: s,cc,q,dum1,dum2
    s=sin(pp)
    cc=cos(pp)**2
    q=(1.0-s*kk)*(1.0+s*kk)
    call rf(cc,q,1.0_dp,dum1)
    call rd(cc,q,1.0_dp,dum2)
    res=s*(dum1-((s*kk)**2)*dum2/3.0)
  END SUBROUTINE elle

end module ellipticalintegrals


! ======================================================================
! NAME
!
!     TRANSFORM
!
! DESCRIPTION
!
!     TRANSFORM is a supporting program of GPECN1DTDPBC that computes
!     the doppler-shifted wavefunction (from a rotating frame to the
!     inertial frame).
!
! AUTHOR
!
!     Marty Kandes, Ph.D.
!     Computational & Data Science Research Specialist
!     User Services Group
!     San Diego Supercomputer Center
!     University of California, San Diego
!
! COPYRIGHT
!
!     Copyright (c) 2010 - 2021 Martin Charles Kandes
!
! LICENSE
!
!     The MIT License (MIT)
!
! LAST UPDATED
!
!     Wednesday, July 5th, 2017
!
! ----------------------------------------------------------------------
      PROGRAM TRANSFORM
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: NUMBER_OF_TIME_STEPS
      INTEGER :: NUMBER_OF_TIME_STEPS_BEFORE_WRITE
      INTEGER :: CURRENT_FILE
      INTEGER :: OUTPUT_SHIFT

      REAL :: RADIUS
      REAL :: ROTATION_RATE
      REAL :: GAMMA_FACTOR

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: WAVEFUNCTION

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: CURRENT_TIME_STEP
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE
      REAL :: TIME_STEP_SIZE

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS_BEFORE_WRITE

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) CURRENT_FILE

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) OUTPUT_SHIFT

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(7,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) ROTATION_RATE

      CALL GET_COMMAND_ARGUMENT(8,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) GAMMA_FACTOR

!     Allocate Arrays:
!     ----------------
      ALLOCATE(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)
      TIME_STEP_SIZE = (RADIUS*ANGULAR_GRID_SPACING_SIZE)**2/(2.0E0*GAMMA_FACTOR)

!     Read Input Arrays from File:
!     ----------------------------
      OPEN(UNIT=CURRENT_FILE,ACTION='READ',FORM='UNFORMATTED')
      READ(UNIT=CURRENT_FILE) WAVEFUNCTION
      CLOSE(UNIT=CURRENT_FILE)

      CURRENT_TIME_STEP = MODULO(CURRENT_FILE,1000) + 1

!     Transform Wavefunction from Rotating Frame to Inertial Frame
!     ------------------------------------------------------------
      DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
         WAVEFUNCTION(CURRENT_GRID_POINT) = EXP(CMPLX(0.0,(ROTATION_RATE*RADIUS**2*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE)-(0.5*ROTATION_RATE**2*RADIUS**2*FLOAT(CURRENT_TIME_STEP-1)*TIME_STEP_SIZE)))*WAVEFUNCTION(CURRENT_GRID_POINT)
      ENDDO

!     Write Converted Output to File:
!     -------------------------------
      OPEN(UNIT=CURRENT_FILE+OUTPUT_SHIFT,ACTION='WRITE',FORM='UNFORMATTED')
         WRITE(UNIT=CURRENT_FILE+OUTPUT_SHIFT) WAVEFUNCTION
      CLOSE(UNIT=CURRENT_FILE+OUTPUT_SHIFT)

!     Format Statements:
!     ------------------
900   FORMAT(1X,4(F23.15))

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(WAVEFUNCTION)

      STOP
      ENDPROGRAM TRANSFORM
! ======================================================================


! Test program for using customized calling subroutine, use
! the Rosenbrock function from driver 1, added constants

!
! CHANGES
! 21.12.2018 - Miha Polajnar
! Initial version
!
program custom1
  use iso_fortran_env, only: rk => real64
  use l_bfgs_b_ag, only: l_bfgs_b, optim_prob_t, lbfgsb_opt_t
  implicit none
  integer, parameter :: n = 2 + 2
  type :: rconst_t
    real(rk) :: a, b
  end type
  type(optim_prob_t) :: optim_prob
  type(lbfgsb_opt_t) :: lbfgsb_opt
  !
  lbfgsb_opt = lbfgsb_opt_t(iprint=200,factr=1.e7_rk,pgtol=0._rk,&
    maxeval=500,m=5)
  !
  optim_prob%name = 'ROSENBROCK - CONSTRANED WITH CUBIC AND LINE'
  optim_prob%n = n
  optim_prob%x = [-1._rk, 2._rk, 1._rk, 1._rk]
  optim_prob%nbd=[ 2, 2, 1, 1 ]
  optim_prob%lb = [ -1.5_rk, -0.5_rk, 0._rk, 0._rk ]
  optim_prob%ub = [  1.5_rk,  2.5_rk, 0._rk, 0._rk ]
  optim_prob%func => rosenbrock
  optim_prob%grad => grad_rosenbrock
  optim_prob%neqc = 2
  optim_prob%eq_const => rosenbrock_eq_const
  optim_prob%grad_eq_const => grad_rosenbrock_eq_const
  ! Run the algorithm
  call l_bfgs_b(optim_prob,lbfgsb_opt)
contains

  real(rk) pure function rosenbrock(x,dat)
    real(rk), intent(in) :: x(:)
    class(*), intent(in) :: dat
    rosenbrock = (1._rk - x(1))**2 + 100._rk *(x(2) - x(1))**2
  end function

  pure subroutine grad_rosenbrock(x,dat,grad)
    real(rk), intent(in) :: x(:)
    class(*), intent(in) :: dat
    real(rk), intent(out) :: grad(:)
    grad(1) = -2._rk * (1._rk - x(1)) - 200._rk * (x(2) - x(1))
    grad(2) = 200._rk * (x(2) - x(1))
    grad(3) = 0._rk
    grad(4) = 0._rk
  end subroutine

  pure subroutine rosenbrock_eq_const(x,dat,ce)
    real(rk), intent(in) :: x(:)
    class(*), intent(in) :: dat
    real(rk), intent(out) :: ce(:)
    ce(1) = -((x(1) - 1._rk)**3 -x(2) + 1._rk) - x(3)
    ce(2) = -(x(1) + x(2) - 2._rk) - x(4)
  end subroutine

  pure subroutine grad_rosenbrock_eq_const(x,dat,grad)
    real(rk), intent(in) :: x(:)
    class(*), intent(in) :: dat
    real(rk), intent(out) :: grad(:,:)
    grad(1,1) = -3._rk * (x(1) - 1._rk)**2
    grad(1,2) = 1._rk
    grad(1,3) = -1._rk
    grad(1,4) = 0._rk
    grad(2,1) = -1._rk
    grad(2,2) = -1._rk
    grad(2,3) = 0._rk
    grad(2,4) = -1._rk
  end subroutine
end program


C
C
*+ fun_gammln

       real function fun_gammln( x, istat )
C      ------------------------------------
C
C Return the logarithm of the gamma function by argument
C
C Given:
C   parameter to the functions
       real*4        x
C Updated:
C   error return
       integer       istat
C
C The logarithm of the Gamma function $\ln(\Gamma(x))$ is defined by:
C \[
C   \Gamma(x) = \int_{0}^{\infty} e^{-z}t^{z-1} dt
C \]
C for $z > 0$.

C ISTAT should be zero on entry.  The only value set by this routine
C is to ILL_INPUTS for illegal ranges on input data.
C
C P. Alexander, MRAO, Cambridge.
C Ref: Numerical Recipes, Press et al., Cambridge. pg. 157.
C-

       include '../include/utilities_errors.inc'

C counters
       integer    j
C local variables (double precision arithmetic)
       real*8     cof(6), stp, half, one, fpf, xx, tmp, ser
       data       cof,stp / 76.18009173D+0, -86.50532033D+0,
     *                      24.01409822D+0, -1.231739516D+0,
     *                      0.120858003D-2, -0.536382D-5,
     *                      2.50662827465D+0 /
       data       half,one,fpf / 0.5D+0, 1.0D+0, 5.5D+0 /

       if (istat.ne.0) return
       if (x.lt.0) then
         istat = ill_inputs
       else if (x.eq.0.0) then
         fun_gammln = 1.0
       else
         xx = x-one
         tmp = xx+fpf
         tmp = (xx+half)*log(tmp)-tmp
         ser = one
         do j=1,6
           xx = xx + one
           ser = ser + cof(j)/xx
         end do
         fun_gammln = tmp+log(stp*ser)
       end if
       call utl_err( istat,'fun_gammln','Failed' )
       end


SUBROUTINE pin_jointed(km,ea,coord)
!
! This subroutine forms the stiffness matrix of a
! general rod element (1-, 2- or 3-d).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ea,coord(:,:)
 REAL(iwp),INTENT(OUT)::km(:,:)
 INTEGER::ndim
 REAL(iwp)::ell,cs,sn,x1,x2,y1,y2,z1,z2,a,b,c,d,e,f,xl,yl,zl,one=1.0_iwp
 ndim=UBOUND(coord,2)
 SELECT CASE(ndim)
 CASE(1)
   ell=coord(2,1)-coord(1,1)
   km(1,1)=one
   km(1,2)=-one
   km(2,1)=-one
   km(2,2)=one
 CASE(2)
   x1=coord(1,1)
   y1=coord(1,2)
   x2=coord(2,1)
   y2=coord(2,2)
   ell=SQRT((y2-y1)**2+(x2-x1)**2)
   cs=(x2-x1)/ell
   sn=(y2-y1)/ell
   a=cs*cs
   b=sn*sn
   c=cs*sn
   km(1,1)=a
   km(3,3)=a
   km(1,3)=-a
   km(3,1)=-a
   km(2,2)=b
   km(4,4)=b
   km(2,4)=-b
   km(4,2)=-b
   km(1,2)=c
   km(2,1)=c
   km(3,4)=c
   km(4,3)=c
   km(1,4)=-c
   km(4,1)=-c
   km(2,3)=-c
   km(3,2)=-c
 CASE(3)
   x1=coord(1,1)
   y1=coord(1,2)
   z1=coord(1,3)
   x2=coord(2,1)
   y2=coord(2,2)
   z2=coord(2,3)
   xl=x2-x1
   yl=y2-y1
   zl=z2-z1
   ell=SQRT(xl*xl+yl*yl+zl*zl)
   xl=xl/ell
   yl=yl/ell
   zl=zl/ell
   a=xl*xl
   b=yl*yl
   c=zl*zl
   d=xl*yl
   e=yl*zl
   f=zl*xl
   km(1,1)=a
   km(4,4)=a
   km(2,2)=b
   km(5,5)=b
   km(3,3)=c
   km(6,6)=c
   km(1,2)=d
   km(2,1)=d
   km(4,5)=d
   km(5,4)=d
   km(2,3)=e
   km(3,2)=e
   km(5,6)=e
   km(6,5)=e
   km(1,3)=f
   km(3,1)=f
   km(4,6)=f
   km(6,4)=f
   km(1,4)=-a
   km(4,1)=-a
   km(2,5)=-b
   km(5,2)=-b
   km(3,6)=-c
   km(6,3)=-c
   km(1,5)=-d
   km(5,1)=-d
   km(2,4)=-d
   km(4,2)=-d
   km(2,6)=-e
   km(6,2)=-e
   km(3,5)=-e
   km(5,3)=-e
   km(1,6)=-f
   km(6,1)=-f
   km(3,4)=-f
   km(4,3)=-f
 END SELECT
 km=km*ea/ell
RETURN
END SUBROUTINE pin_jointed


program Arithematic_Operation
    implicit none
    !You can do any of the two

    !Method one
    ! real :: a = 4.0,b =2.0
    !Method two
    real :: a, b
    ! a = 4.0
    ! b = 2.0

    !assingning a and b can be done in one line
    a = 4.0; b = 2.0

    print *, a + b
    print *, a - b
    print *, a*b
    print *, a/b
    print *, a**b
end program Arithematic_Operation


Subroutine trans(A, n, ans)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A
	Double Precision, Dimension(n, n), Intent(Out) :: ans

	Integer :: i, j

	Do i = 1, n
		Do j = 1, n
			ans(i, j) = A(j, i)
		End Do
	End Do
End Subroutine trans


      module MOMENTS

      contains

      SUBROUTINE MOMENT0_ELIMIN(ND, R, L, JMAX, Z, XJ, XJMEAN)

C***  INTEGRATION OF THE ZERO-MOMENT OF THE RADIATION FIELD (MEAN INTENSITY)
C***   IF ( MODE = .TRUE.    ) THE INTEGRATION WEIGHTS ARE GENERATED (VECTOR XJ)
C***   ELSE : XJ IS CONSIDERED AS ANGLE-DEPENDENT INTENSITY AND THE
C***          INTEGRATION IS PERFORMED ( RESULT XJMEAN)
C***  RADIUS-MESH R, ACTUAL INDEX L, AND Z-MESH Z(L,J) ARE GIVEN
C***  WEIGHTS ARE ACCORDING TO TRAPEZOIDAL RULE IN Z=SQRT(R*R-P*P)
CMH	INTEGRATION WEIGHTS XJ = DZ/2/R IN "\MU" UNITS

      implicit real*8(a - h, o - z)

      real*8, intent(in) :: R(ND), Z(ND, JMAX), XJ(JMAX)

      real*8, intent(out) :: XJMEAN

      RL2 = 2d0 * R(L)

C***  FIRST STEP
      ZJ = Z(L, 1)
      ZNEXT = Z(L, 2)

      XJMEAN = (ZJ - ZNEXT) * XJ(1)

!      write(*, '(A,2(2x,i4),4(2x,e15.7))'), 'moment0, check 1:', L, 1, zj, znext, xj(1), xjmean

C***  MIDDLE STEPS
      DO J = 3, JMAX

         ZLAST = ZJ
         ZJ = ZNEXT
         ZNEXT = Z(L, J)

         XJMEAN = XJMEAN + XJ(J - 1) * (ZLAST - ZNEXT)

!         write(*, '(A,2(2x,i4),4(2x,e15.7))'), 'moment0, check 2:', L, j - 1, zlast, znext, xj(j - 1), xjmean

      ENDDO

C***  LAST STEP, IMPLYING Z(L,JMAX)=.0
      XJMEAN=XJMEAN+XJ(JMAX)*ZJ
      XJMEAN=XJMEAN/RL2

!      write(*, '(A,2(2x,i4),4(2x,e15.7))'), 'moment0, check 3:', L, jmax, zj, rl2, xj(jmax), xjmean

      end subroutine

      SUBROUTINE MOMENT0_SETUP(ND, R, L, JMAX, Z, XJ)

C***  INTEGRATION OF THE ZERO-MOMENT OF THE RADIATION FIELD (MEAN INTENSITY)
C***   IF ( MODE = .TRUE.    ) THE INTEGRATION WEIGHTS ARE GENERATED (VECTOR XJ)
C***   ELSE : XJ IS CONSIDERED AS ANGLE-DEPENDENT INTENSITY AND THE
C***          INTEGRATION IS PERFORMED ( RESULT XJMEAN)
C***  RADIUS-MESH R, ACTUAL INDEX L, AND Z-MESH Z(L,J) ARE GIVEN
C***  WEIGHTS ARE ACCORDING TO TRAPEZOIDAL RULE IN Z=SQRT(R*R-P*P)
CMH	INTEGRATION WEIGHTS XJ = DZ/2/R IN "\MU" UNITS

      implicit real*8(a - h, o - z)

      real*8, intent(in) ::  R(ND), Z(ND, JMAX)

      real*8, intent(out) :: XJ(JMAX)

      RL2 = 2d0 * R(L)

C***  FIRST STEP
      ZJ = Z(L, 1)
      ZNEXT = Z(L, 2)

      XJ(1) = (ZJ - ZNEXT) / RL2

!     print*, 'moment0, check 1:', zj, znext, xj(1), xjmean

C***  MIDDLE STEPS
      DO J = 3, JMAX

         ZLAST = ZJ
         ZJ = ZNEXT
         ZNEXT = Z(L, J)

         XJ(J-1)=(ZLAST-ZNEXT)/RL2

!        print*, 'moment0, check 2:', xjmean

      ENDDO

C***  LAST STEP, IMPLYING Z(L,JMAX)=.0
      XJ(JMAX) = ZJ / RL2

!     print*, 'moment0, check 3:', xjmean

      end subroutine

      SUBROUTINE MOMENT1(R, NP, P, U, H)
C***  CALCULATES AN ANGLE INTEGRAL H OF THE RADIATION FIELD U
C***  BESIDES OF THE OUTER BOUNDARY, THIS IS NOT THE 1. MOMENT H,
C***  BUT RATHER AN INTENSITY-LIKE QUANTITY
C***  INTEGRATION WITH TRAPEZOIDAL RULE, WEIGHTS P * DP
      implicit real*8(a-h,o-z)

      DIMENSION U(NP),P(NP)
      NPM=NP-1
      A=.0
      B=P(2)
      W=(B-A)*(B+2.*A)
      H=W*U(1)
    1 DO 2 J=2,NPM
      C=P(J+1)
      W=(A+B+C)*(C-A)
      H=H+W*U(J)
    3 A=B
    2 B=C
      W=(B-A)*(2.*B+A)
      H=H+W*U(NP)
    7 H=H/R/R/6.
      RETURN

      end subroutine

      SUBROUTINE MOMENT2(R, JMAX, P, U, XK)

C***  INTEGRATION OF THE 2. MOMENT XK OF THE RADIATION FIELD U
C***  FEAUTRIER-INTENSITY U(J), IMPACT PARAMETER MESH P(J)
C***  AND RADIUS POINT R ARE GIVEN.
C***  WEIGHTS ARE ACCORDING TO TRAPEZOIDAL RULE IN Z*Z*DZ, Z=SQRT(R*R-P*P)

      implicit real*8(a - h, o - z)

      DIMENSION P(JMAX), U(JMAX)

      RR = R * R

C***  FIRST STEP, IMPLYING P(1)=0
      Z=R
      ZQ=RR
      PJ=P(2)
      ZNQ = (R - PJ) * (R + PJ)
      ZNEXT=SQRT(ZNQ)
      W=Z*(3*ZQ-ZNQ)-ZNEXT*(ZQ+ZNQ)
      XK=W*U(1)

C***  MIDDLE STEPS
      DO J = 3, JMAX

         ZLAST = Z
         ZLQ = ZQ
         Z = ZNEXT
         ZQ = ZNQ
         PJ = P(J)
         ZNQ = (R - PJ) * (R + PJ)
         ZNEXT = SQRT(ZNQ)
         W = Z * (ZLQ - ZNQ) + ZLAST * (ZLQ + ZQ) - ZNEXT * (ZQ + ZNQ)
         XK = XK + W * U(J - 1)

      enddo

C***  LAST STEP, IMPLYING P(JMAX)=R
      W=Z*ZQ
      XK=XK+W*U(JMAX)
      XK=XK/R/RR/12.

      RETURN

      end subroutine

      end module


c     program DRDINT1R
c>> 1994-10-19 DRDINT1R Krogh  Changes to use M77CON
c>> 1994-08-08 DRDINT1R Snyder  Took '0' out of formats for C conversion
c>> 1991-11-20 CLL Edited for Fortran 90.
c>> 1987-12-09 DRDINT1R Snyder  Initial Code.
c--D replaces "?": DR?INT1R, ?INT1, ?INTA
c
c     DEMO DRIVER for 1 dimensional quadrature subprogram DINT1.
c
c     Compute the integral for X = 0.0 to X = PI of SIN(X), then
c     subtract 2.0 from the ANSWER.  The result should be zero.
c
c     The integrand is evaluated using reverse communication.
c
      double precision A, B, ANSWER, WORK(1)
      integer IOPT(10)
c
10    format (/' DRDINT1R:'/
     1' Compute the integral for X = 0.0 to X = PI of SIN(X), then'/
     2' subtract 2.0 from the ANSWER.  The result should be zero.')
20    format (/' ANSWER          =',G15.8/
     1         ' ERROR ESTIMATE  =',G15.8/
     2         ' STATUS FLAG     =',I6/
     3         ' FUNCTION VALUES =',I6)
c
      print 10
      A = 0.0D0
      B = 4.0D0 * ATAN(1.0D0)
      IOPT(2) = 10
      IOPT(3) = 0
      IOPT(4) = 6
      IOPT(5) = 0
      call DINT1 (A, B, ANSWER, WORK, IOPT)
 30   continue
      call DINTA (ANSWER, WORK, IOPT)
      if (IOPT(1) .eq. 0) then
         ANSWER = SIN(WORK(1))
         go to 30
      end if
      print 20, ANSWER, WORK(1), IOPT(1), IOPT(3)
      stop
      end


      INCLUDE 'VICMAIN_FOR'

      SUBROUTINE MAIN44

         IMPLICIT NONE

         INTEGER*2 BUF(10000)
         INTEGER HIST(-4095:4095)
         INTEGER PARB(500),IND,ICNT,IDEF
         INTEGER S_IND,E_IND,NLI,NSI,SL,SS,NL,NS,JST,ISPIKE
         INTEGER IAREA(4),IST,S_PLUS_E,INPUT,IEL,LINE,ZERO,NPRP,J

         CHARACTER*4   FORMAT
         CHARACTER*80  PROP
         CHARACTER*160 MSG
         CHARACTER*255 DISTFILE

         REAL*4 LOG2,ENTRPY,XSUM,XSUM2,AREA,XABORT,XADD,PJ,XMEAN
         REAL*4 SIGMADELDN

         LOGICAL XVPTST,DIST_FLAG

         MSG = ' '
         DIST_FLAG = .FALSE.

C        max values for histogram
         S_IND = -4095
         E_IND = 4095
         S_PLUS_E = E_IND + ABS(S_IND) + 1

         CALL IFMESSAGE ('ENTROPY version April 22, 2000')
         CALL XVUNIT(INPUT,'INP',1,IND,' ')

C     check to see whether to put the entropy value into the frame's label.
         IF (XVPTST('LABEL')) THEN
            CALL XVOPEN(INPUT,ind,'OPEN_ACT','SA','IO_ACT','SA',
     &               'U_FORMAT','HALF','OP','UPDATE',' ')
         ELSE
            CALL XVOPEN(INPUT,IND,'OPEN_ACT','SA','IO_ACT','SA',
     &               'U_FORMAT','HALF',' ')
         ENDIF

C        check for output normalized difference histogram file name.
         CALL XVPARM('DISTFILE',DISTFILE,ICNT,IDEF,' ')
         IF (ICNT .GE. 1) THEN
            OPEN (13, FILE=DISTFILE, STATUS='UNKNOWN',
     &            IOSTAT=JST,ERR=994)
            DIST_FLAG = .TRUE.
         ENDIF

         CALL XVGET(INPUT,IND,'NL',NLI,'NS',NSI,' ')
         CALL XVGET(INPUT,IND,'FORMAT',FORMAT,' ')
         IF ((FORMAT .NE. 'BYTE') .AND. (FORMAT .NE.'HALF')) GOTO 992

         CALL XVPARM('AREA',IAREA,ICNT,IDEF,' ')
         IF(ICNT .EQ. 0)THEN
            SL=1
            SS=1
            NL=NLI
            NS=NSI
         ELSE
            SL=IAREA(1)
            SS=IAREA(2)
            NL=IAREA(3)
            NS=IAREA(4)
         ENDIF

         IF((SL .GT. NLI) .OR. (SL+NL-1 .GT. NLI) .OR.
     &      (SS .GT. NSI) .OR. (SS+NS-1 .GT. NSI)) GOTO 995

         CALL ZIA(HIST,S_PLUS_E)

         XSUM = 0.0
         XSUM2 = 0.0
         IEL = SL + NL - 1
         DO LINE=SL, IEL
            CALL XVREAD(INPUT,BUF,IND,'LINE',LINE,'SAMP',SS,
     &                  'NSAMPS',NS,' ')
            CALL DIFFHIST(BUF,NS,HIST,XSUM,XSUM2,S_IND,E_IND,*993)
         ENDDO

         ZERO = 0
         ISPIKE = 1
         IF (XVPTST('ZEROES')) ZERO = 1
         IF (XVPTST('PHIST')) THEN
            CALL PHIST(HIST,S_PLUS_E,S_IND,E_IND,ISPIKE,ZERO)
         ELSE IF (ZERO .EQ. 1) THEN
            WRITE (MSG,'(A30,A32)')
     &         'The ZEROES keyword is ignored,',
     &         ' because PHIST is not specified.'
            CALL XVMESSAGE (MSG,' ')
         END IF

C      ....Use the formula:          H  =  - >  p log p    to find entropy.
C                                            -   j   2 j
         LOG2 = ALOG(2.)
         AREA = NL*(NS-1)
         ENTRPY = 0.0

         DO J=S_IND, E_IND
            PJ = HIST(J)/AREA
            IF (HIST(J).GT.0.) THEN
C               PJ = HIST(J)/AREA
               ENTRPY = ENTRPY - PJ*ALOG(PJ)/LOG2
            ENDIF
            IF (DIST_FLAG) THEN
               WRITE (13, 1001) J, PJ
1001           FORMAT (1x, I5, 3x, F7.5)
            ENDIF
         ENDDO

         IF (DIST_FLAG) CLOSE (13)

         XMEAN = XSUM/AREA
         SIGMADELDN=SQRT((XSUM2-AREA*XMEAN**2)/(AREA-1))

         WRITE(MSG,'(A9,F8.5,2x,A18,F9.5,2x,A15,I8)')
     &      'ENTROPY = ',ENTRPY,' SIGMA_DELTA_DN = ',SIGMADELDN,
     &      ' #_OF_PIXELS = ',IFIX(AREA)
         CALL XVMESSAGE(MSG,' ')

C        output value to TCL local variable
         CALL XQINI(PARB,500,XABORT)
         CALL XQREAL(PARB,'VALUE',1,ENTRPY,XADD,IST)
         CALL XVQOUT(PARB,IST)

         IF (XVPTST('NOLABEL')) RETURN

C        add a label item
C        update label only if AREA is equal to size of the image
         IF ((NL .NE. NLI) .OR. (NS .NE. NSI) .OR.
     &       (SL .NE. 1) .OR. (SS .NE.1)) THEN
            CALL XVMESSAGE
     &      ('AREA not equal to image size.  ITEM NOT ADDED',' ')
            RETURN
         ENDIF

         CALL XLADD(INPUT,'HISTORY','ENTROPY',ENTRPY,IST,
     &         'MODE','REPLACE','FORMAT','REAL',' ')
         IF (IST .NE. 1) GOTO 991
         CALL XVMESSAGE ('ENTROPY ADDED TO HISTORY LABEL',' ')

         RETURN

991	 CALL XVMESSAGE
     &      ('***Error writing history label item',' ')
	 GOTO 999
992	 CALL XVMESSAGE
     &      ('***Input image must be byte or halfword format',' ')
	 GOTO 999
993	 CALL XVMESSAGE ('***Invalid DN values',' ')
         GOTO 999
994      CALL XVMESSAGE('***Error opening distribution output file',' ')
         GOTO 999
995      CALL XVMESSAGE ('***Selected area is outside of image',' ')
999	 CALL XVMESSAGE ('***Entropy task cancelled',' ')
         CALL ABEND
      END

C Compute difference histogram (HIST).
      SUBROUTINE DIFFHIST(BUF,NPTS,HIST,XSUM,XSUM2,S_IND,E_IND,*)

         INTEGER S_IND,E_IND,NPTS,J,IDEL,I0,I1
         INTEGER HIST(S_IND:E_IND)
         INTEGER*2 BUF(NPTS)

         REAL*4 XSUM, XSUM2

	 I0 = BUF(1)
         IF ((I0 .GT. E_IND) .OR. (I0 .LT. 0)) GOTO 5

         DO J=2,NPTS
            I1 = BUF(J)
            IF ((I1 .GT. E_IND) .OR. (I1 .LT. 0)) GOTO 5
            IDEL = I1 - I0
            XSUM = XSUM + IDEL
            XSUM2 = XSUM2 + IDEL * IDEL
            HIST(IDEL) = HIST(IDEL) + 1
            I0 = I1
         ENDDO
         RETURN
5        RETURN 1
      END


!-----------------------------------------------------------------------
subroutine transform(N,x,xmin,xmax,convert,y)
use Interface_MOD, only : NO
implicit none

integer, intent(in)       :: N

! Input vector can be original values or need to be converted back
real, intent(in)          :: x(N)

! The minimal allowed positive values in x, to avoid zero or negative values
! These values are normal values before transformation
real, intent(in)          :: xmin,xmax

! Whether to lognorm or convert back to normal values
integer, intent(in)       :: convert

real, intent(out)         :: y(N)

real :: max_y,min_y

integer :: i

! Normalization occurs after sqrt(x)  !
min_y = sqrt(xmin)
max_y = sqrt(xmax)

if (convert .eq. NO) then
   do i = 1, N
      if (x(i) < 0.) stop "Negative values in input data!"
      y(i) = sqrt(x(i))
      y(i) = (y(i)-min_y)/(max_y-min_y)
   enddo
else
   do i = 1, N
      y(i) = x(i)*(max_y-min_y) + min_y
      y(i) = y(i)**2
   enddo
endif
end subroutine transform


program pgm
  integer array(10, 10)
  real c,d
  integer i, j
  c = 10.01

  do j = 1, 10, 1
    do i = 1, 10, 1
      array(i, j) = i + j
    end do
  end do

  print *, array(10, 10)
end


    program AOC15

    implicit none

    integer, parameter :: xysize = 100
    character(*), parameter :: file='input.txt'

    logical :: notinset(xysize,xysize)
    integer :: risks(xysize,xysize), costs(xysize,xysize)
    integer :: i,j,curx,cury,candidate(2),newcost
    integer, parameter :: adjx(4) = [-1,1,0,0], adjy(4)=[0,0,1,-1]

    open (unit=1, file=file, form='formatted', status='old')
    do i=1,xysize
        read (1,'(*(I1))') (risks(i,j),j=1,xysize)
    end do
    costs = huge(0)
    costs(1,1) = 0
    notinset = .true.

    do
       ! write (*,'(10(10I3/)/)') (costs(i,:),i=1,10)
        candidate = minloc(costs,mask=notinset)
       !write (*,*) candidate
        cury = candidate(1)
        curx = candidate(2)
        if ((curx == xysize) .and. (cury == xysize)) exit
        notinset(cury,curx) = .false.
        do i=1,4
            if ((curx+adjx(i) < 1) .or. (curx+adjx(i) > xysize)) cycle
            if ((cury+adjy(i) < 1) .or. (cury+adjy(i) > xysize)) cycle
            if (notinset(cury+adjy(i),curx+adjx(i))) then
                newcost = costs(cury,curx) + risks(cury+adjy(i),curx+adjx(i))
                if (newcost < costs(cury+adjy(i),curx+adjx(i))) &
                    costs(cury+adjy(i),curx+adjx(i)) = costs(cury,curx) + risks(cury+adjy(i),curx+adjx(i))
            end if
        end do
    end do

    print *, costs(xysize,xysize)

    end program AOC15


      subroutine ludcmp(aa,n,np,indx,d)
c---------------------------------------------------------------------
c
c  find the LU decomposition of a matrix.
c
c  Numerical Recipes: p. 38
c
c---------------------------------------------------------------------
      include "common.h"

      dimension aa(np,np), indx(n), vv(500)

      d=1.0
      do i=1,n
         aamax=0.0
         do j=1,n
            if (abs(aa(i,j)).gt.aamax) aamax=abs(aa(i,j))
         enddo
         vv(i)=1.0/aamax
      enddo

      do j=1,n
         do i=1,j-1
            sum=aa(i,j)
            do k=1,i-1
               sum=sum-aa(i,k)*aa(k,j)
            enddo
            aa(i,j)=sum
         enddo
         aamax = 0.0
         do i=j,n
            sum=aa(i,j)
            do k=1,j-1
               sum=sum-aa(i,k)*aa(k,j)
            enddo
            aa(i,j)=sum
            dum=vv(i)*abs(sum)
            if (dum.ge.aamax) then
               imax=i
               aamax=dum
            endif
         enddo
         if (j.ne.imax) then
            do k=1,n
               dum=aa(imax,k)
               aa(imax,k)=aa(j,k)
               aa(j,k)=dum
            enddo
            d=-d
            vv(imax)=vv(j)
         endif
         indx(j)=imax
         if(j.ne.n)then
            dum=1.0/aa(j,j)
            do i=j+1,n
               aa(i,j)=aa(i,j)*dum
            enddo
         endif
      enddo

      return
      end


      SUBROUTINE MB01UW( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA,
     $                   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 one of the matrix products
C
C        A : = alpha*op( H ) * A, or A : = alpha*A * op( H ),
C
C     where alpha is a scalar, A is an m-by-n matrix, H is an upper
C     Hessenberg matrix, and op( H ) is one of
C
C        op( H ) = H   or   op( H ) = H',  the transpose of H.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether the Hessenberg matrix H appears on the
C             left or right in the matrix product as follows:
C             = 'L':  A := alpha*op( H ) * A;
C             = 'R':  A := alpha*A * op( H ).
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( H ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( H ) = H;
C             = 'T':  op( H ) = H';
C             = 'C':  op( H ) = H'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then H is not
C             referenced and A need not be set before entry.
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,k)
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C             On entry with SIDE = 'L', the leading M-by-M upper
C             Hessenberg part of this array must contain the upper
C             Hessenberg matrix H.
C             On entry with SIDE = 'R', the leading N-by-N upper
C             Hessenberg part of this array must contain the upper
C             Hessenberg matrix H.
C             The elements below the subdiagonal are not referenced,
C             except possibly for those in the first column, which
C             could be overwritten, but are restored on exit.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,k),
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading M-by-N part of this array contains
C             the computed product.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, alpha <> 0, and LDWORK >= M*N > 0,
C             DWORK contains a copy of the matrix A, having the leading
C             dimension M.
C             This array is not referenced when alpha = 0.
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= 0,   if  alpha =  0 or MIN(M,N) = 0;
C             LDWORK >= M-1, if  SIDE  = 'L';
C             LDWORK >= N-1, if  SIDE  = 'R'.
C             For maximal efficiency LDWORK should be at least M*N.
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     The required matrix product is computed in two steps. In the first
C     step, the upper triangle of H is used; in the second step, the
C     contribution of the subdiagonal is added. If the workspace can
C     accomodate a copy of A, a fast BLAS 3 DTRMM operation is used in
C     the first step.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, January 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SIDE, TRANS
      INTEGER           INFO, LDA, LDH, LDWORK, M, N
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), H(LDH,*)
C     .. Local Scalars ..
      LOGICAL           LSIDE, LTRANS
      INTEGER           I, J, JW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DLACPY, DLASCL, DLASET, DSCAL, DSWAP,
     $                  DTRMM, DTRMV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LSIDE  = LSAME( SIDE,  'L' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF(      ( .NOT.LSIDE  ).AND.( .NOT.LSAME( SIDE,  'R' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR.
     $                  ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDWORK.LT.0 .OR.
     $       ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND.
     $            ( ( LSIDE .AND. LDWORK.LT.M-1 ) .OR.
     $         ( .NOT.LSIDE .AND. LDWORK.LT.N-1 ) ) ) ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01UW', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF ( MIN( M, N ).EQ.0 ) THEN
         RETURN
      ELSE IF ( LSIDE ) THEN
         IF ( M.EQ.1 ) THEN
            CALL DSCAL( N, ALPHA*H(1,1), A, LDA )
            RETURN
         END IF
      ELSE
         IF ( N.EQ.1 ) THEN
            CALL DSCAL( M, ALPHA*H(1,1), A, 1 )
            RETURN
         END IF
      END IF
C
      IF( ALPHA.EQ.ZERO ) THEN
C
C        Set A to zero and return.
C
         CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
         RETURN
      END IF
C
      IF( LDWORK.GE.M*N ) THEN
C
C        Enough workspace for a fast BLAS 3 calculation.
C        Save A in the workspace and compute one of the matrix products
C          A : = alpha*op( triu( H ) ) * A, or
C          A : = alpha*A * op( triu( H ) ),
C        involving the upper triangle of H.
C
         CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M )
         CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H,
     $               LDH, A, LDA )
C
C        Add the contribution of the subdiagonal of H.
C        If SIDE = 'L', the subdiagonal of H is swapped with the
C        corresponding elements in the first column of H, and the
C        calculations are organized for column operations.
C
         IF( LSIDE ) THEN
            IF( M.GT.2 )
     $         CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
            IF( LTRANS ) THEN
               JW = 1
               DO 20 J = 1, N
                  JW = JW + 1
                  DO 10 I = 1, M - 1
                     A( I, J ) = A( I, J ) +
     $                           ALPHA*H( I+1, 1 )*DWORK( JW )
                     JW = JW + 1
   10             CONTINUE
   20          CONTINUE
            ELSE
               JW = 0
               DO 40 J = 1, N
                  JW = JW + 1
                  DO 30 I = 2, M
                     A( I, J ) = A( I, J ) +
     $                           ALPHA*H( I, 1 )*DWORK( JW )
                     JW = JW + 1
   30             CONTINUE
   40          CONTINUE
            END IF
            IF( M.GT.2 )
     $         CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
         ELSE
C
            IF( LTRANS ) THEN
               JW = 1
               DO 50 J = 1, N - 1
                  IF ( H( J+1, J ).NE.ZERO )
     $               CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1,
     $                           A( 1, J+1 ), 1 )
                  JW = JW + M
   50          CONTINUE
            ELSE
               JW = M + 1
               DO 60 J = 1, N - 1
                  IF ( H( J+1, J ).NE.ZERO )
     $               CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1,
     $                           A( 1, J ), 1 )
                  JW = JW + M
   60          CONTINUE
            END IF
         END IF
C
      ELSE
C
C        Use a BLAS 2 calculation.
C
         IF( LSIDE ) THEN
            IF( M.GT.2 )
     $         CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
            IF( LTRANS ) THEN
               DO 80 J = 1, N
C
C                 Compute the contribution of the subdiagonal of H to
C                 the j-th column of the product.
C
                  DO 70 I = 1, M - 1
                     DWORK( I ) = H( I+1, 1 )*A( I+1, J )
   70             CONTINUE
C
C                 Multiply the upper triangle of H by the j-th column
C                 of A, and add to the above result.
C
                  CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH,
     $                        A( 1, J ), 1 )
                  CALL DAXPY( M-1, ONE, DWORK, 1, A( 1, J ), 1 )
   80          CONTINUE
C
            ELSE
               DO 100 J = 1, N
C
C                 Compute the contribution of the subdiagonal of H to
C                 the j-th column of the product.
C
                  DO 90 I = 1, M - 1
                     DWORK( I ) = H( I+1, 1 )*A( I, J )
   90             CONTINUE
C
C                 Multiply the upper triangle of H by the j-th column
C                 of A, and add to the above result.
C
                  CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH,
     $                        A( 1, J  ), 1 )
                  CALL DAXPY( M-1, ONE, DWORK, 1, A( 2, J ), 1 )
  100          CONTINUE
            END IF
            IF( M.GT.2 )
     $         CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
         ELSE
C
C           Below, row-wise calculations are used for A.
C
            IF( N.GT.2 )
     $         CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
            IF( LTRANS ) THEN
               DO 120 I = 1, M
C
C                 Compute the contribution of the subdiagonal of H to
C                 the i-th row of the product.
C
                  DO 110 J = 1, N - 1
                     DWORK( J ) = A( I, J )*H( J+1, 1 )
  110             CONTINUE
C
C                 Multiply the i-th row of A by the upper triangle of H,
C                 and add to the above result.
C
                  CALL DTRMV( 'Upper', 'NoTranspose', 'Non-unit', N, H,
     $                        LDH, A( I, 1 ), LDA )
                  CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 2 ), LDA )
  120          CONTINUE
C
            ELSE
               DO 140 I = 1, M
C
C                 Compute the contribution of the subdiagonal of H to
C                 the i-th row of the product.
C
                  DO 130 J = 1, N - 1
                     DWORK( J ) = A( I, J+1 )*H( J+1, 1 )
  130             CONTINUE
C
C                 Multiply the i-th row of A by the upper triangle of H,
C                 and add to the above result.
C
                  CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', N, H,
     $                        LDH, A( I, 1 ), LDA )
                  CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 1 ), LDA )
  140          CONTINUE
            END IF
            IF( N.GT.2 )
     $         CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
         END IF
C
C        Scale the result by alpha.
C
         IF ( ALPHA.NE.ONE )
     $      CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA,
     $                   INFO )
      END IF
      RETURN
C *** Last line of MB01UW ***
      END


      SUBROUTINE PASSB3 (IDO,L1,CC,CH,WA1,WA2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
C     *** TAUI IS SQRT(3)/2 ***
      DATA TAUR,TAUI /-0.5D0,0.86602540378443864676D0/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
      END


! Copyright (c) 2021, University of Colorado Denver. All rights reserved.
!
! This file is part of <T>LAPACK.
! <T>LAPACK is free software: you can redistribute it and/or modify it under
! the terms of the BSD 3-Clause license. See the accompanying LICENSE file.

program example_fortranModule_caxpy
use tblas
implicit none
    logical, parameter            :: verbose = .false.

    integer(blas_size), parameter :: n = 10
    integer(blas_int),  parameter :: incx = 1, incy = 1
    complex(sp),        parameter :: c = ( 0.e0, -1.e0 )

    complex(sp)                   :: x(n), y(n)
    integer(blas_size)            :: i

    real(sp)                      :: error1
    complex(sp)                   :: aux

    intrinsic                     :: abs

    ! Fill arrays
    do i = 1, n
        x(i) = complex(i, sp) * c
        y(i) = 10*complex(i, sp) * ( 0.e0, 1.e0 )
    end do

    if( verbose ) then
        ! Print arguments
        print *, "[IN] x = "
        do i = 1, n
            print *, x(i)
        end do
        print *, "[IN] y = "
        do i = 1, n
            print *, y(i)
        end do
        print *, "[IN] c = ", c
    end if

    ! Call caxpy
    call caxpy( n, c, x, incx, y, incy )

    if( verbose ) then
        ! Print result
        print *, "caxpy: c*x + y = "
        do i = 1, n
            print *, y(i)
        end do
    end if

    ! Error
    error1 = 0.e0
    do i = 1, n
        aux = complex(i, sp) * ( -1.e0, 10.e0 )
        error1 = error1 + abs( y(i) - aux )
    end do
    print *, "||y_exact - y_caxpy||_1 = ", error1

end program


SUBROUTINE Matrix
   USE PrecTypes
   USE GlobalData
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   Matrix
   ! PARENT: Feritas
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Construct stiffness matrix and nodal force vector.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER :: i,j

   ! -------------------------------------------------------------------------
   ! Matrix map (only for debugging)
   character(len=1), allocatable :: im(:,:)
   ! -------------------------------------------------------------------------

   Km = 0.0_dp  ! Initialize the stiffness matrix
   Fv = 0.0_dp  ! Initialize the equivalent nodal force vector
   Kmm = 0.0_dp ! Initialize the sub stiffness matrix for calculating the nodal reaction force
   Fvv = 0.0_dp ! Initialize the equivalent nodal force vector for calculating the nodal reaction force

   SELECT CASE(pcode)

      ! Potential problem --------------------
      CASE (1)

         DO i=1,ne  ! Counting the current element

            ! Computation of element stiffness matrix
            SELECT CASE( etype(i) )
               CASE (3) ! Triangular linear element

                  ! Computation of element stiffness matrix of triangular linear elmenet
                  CALL Mat_Poten2TrigLinear(i)

               case (4) ! Rectilinear element

                  ! Computation of element stiffness matrix of triangular rectilinear elmenet
                  CALL Mat_Poten2RectLinear(i)

            END SELECT

         END DO ! <-- i=1,ne

         ! Just for debugging ----------------
         if (node <= 60) then
            allocate(im(node,node))
            do i=1,node
               do j=1,node
                  if(Km(i,j) == 0.0_dp) then
                     im(i,j) = '.'
                  elseif(Km(i,j) > 0.0_dp) then
                     im(i,j) = 'o'
                  else
                     im(i,j) = 'x'
                  end if
               end do
            end do

            do i=1,N_unknowns
               write(*,'(18(1x,a))') (im(i,j),j=1,N_unknowns)
            end do
         end if
         !---------------------------

         ! Equivalent nodal heat vector on the right-hand side of the system of equations
         DO i=1,ns   ! Repeating for the number of boundary elements

            SELECT CASE( Stype(i) )
               ! Straight linear elements (corresponding to the edges of triangles and rectangles)
               CASE (2)
                  ! Computations of right-hand side vector for linear boundary edge elements
                  CALL F_Poten2Linear(i)

            END SELECT

         END DO  ! <-- i=1,ns

      ! Linear elastostatic problems-------------------------
      CASE (2,3)

         DO i=1,ne  ! Counting the current element

            ! Computation of element stiffness matrix
            SELECT CASE( etype(i) )
               CASE (3) ! Triangular linear element

                  ! Computation of element stiffness matrix of triangular linear elmenet
                  CALL Mat_Elast2TrigLinear(i)

               CASE (4) ! Rectilinear element

                  ! Computation of element stiffness matrix of triangular rectilinear elmenet
                  CALL Mat_Elast2RectLinear(i)

            END SELECT

         END DO ! <-- i=1,ne

         ! Just for debugging ----------------
         if (node<=60) then
            allocate(im(dir*node,dir*node))
            do i=1,dir*node
               do j=1,dir*node
                  if(Km(i,j) == 0.0_dp) then
                     im(i,j) = '.'
                  elseif(Km(i,j) > 0.0_dp) then
                     im(i,j) = 'o'
                  else
                     im(i,j) = 'x'
                  end if
               end do
            end do

            do i=1,N_unknowns
               write(*,'(18(1x,a))') (im(i,j),j=1,N_unknowns)
            end do
         end if
         !---------------------------

         ! Equivalent nodal force vector on the right-hand side of the system of equations
         DO i=1,ns   ! Repeating for the number of boundary elements

            SELECT CASE( Stype(i) )
               ! Straight linear elements (corresponding to the edges of triangles and rectangles)
               CASE (2)
                  ! Computations of right-hand side vector for linear boundary edge elements
                  CALL F_Elast2Linear(i)

            END SELECT

         END DO  ! <-- i=1,ns

   END SELECT

   RETURN
END SUBROUTINE Matrix


program sum
implicit none

integer         :: i
integer(kind=8) :: s

s = 0
do i = 1, 1000000000
   s = s + i
end do

write(*,*) 'sum: ', s

end program sum


module m_sim
  use m_bc,     only: apply_boundary_conditions
  use m_fdm
  use m_mg,     only: MGsolve_2DPoisson
  use m_stream, only: compute_velocity
  implicit none

  private
  public :: simulation

  ! ----------------------
  ! simulation type
  ! ----------------------
  type :: simulation
    real :: dt
    real :: total_time
  contains
    procedure, private, nopass :: compute_dt
    procedure, public, pass    :: read_inputs
    procedure, public, nopass  :: initialize
    procedure, public, pass    :: evolve
    procedure, public, nopass  :: export_results
    procedure, public, nopass  :: destroy
  end type simulation

  ! -------------------------
  ! constants
  ! -------------------------
  real, parameter :: pi = 3.141592653589793238462643383279502884 ! pi
  real, parameter :: k = 1.0 ! thermal diffusivity
  integer, parameter :: niters = 50 ! maximum number of iterations of MG solver

  ! -------------------------
  ! ids of input/output files
  ! -------------------------
  integer, parameter :: input_file_id = 1
  integer, parameter :: v_file_id = 2
  integer, parameter :: S_file_id = 1
  integer, parameter :: W_file_id = 1
  integer, parameter :: T_file_id = 1

  ! -------------------------
  ! default parameter file
  ! -------------------------
  character(len=100) :: input_file_name = 'parameters.txt'

  ! ----------------------------------------------
  ! input parameters to be set from parameter file
  ! ----------------------------------------------
  integer :: nx = 257, ny = 65          ! number of grid-points in x- and y-direction
  real :: total_time = 0.1              ! integration time
  real :: Ra = 1.e6                     ! Rayleigh number
  real :: Pr = 0.01                     ! Prandtl number
  real :: beta = 0.5                    ! explicit/implicit/semi-implicit
  real :: err = 1.e-3                   ! prescribed tolerance for MG solver
  real :: a_dif = 0.15, a_adv = 0.4     ! diffusion and advection timestep parameters
  character(len=15) :: Tinit = 'cosine' ! initial condition for temperature

  ! ----------------------------------------------
  ! utility variables
  ! ----------------------------------------------
  real :: h, dt_dif, dt_adv

  ! ----------------------------------------------
  ! field arrays
  ! ----------------------------------------------
  real, allocatable :: S(:, :), vx(:, :), vy(:, :), v(:, :)
  real, allocatable :: T(:, :), dT2(:, :), dTx(:, :), dTy(:, :), T_rhs(:, :)
  real, allocatable :: W(:, :), dW2(:, :), dWx(:, :), dWy(:, :), W_rhs(:, :)
  real, allocatable :: Ra_dTdx(:, :)

contains

  subroutine read_inputs(this)
    implicit none
    ! arguments
    class(simulation), intent(inout) :: this
    ! local variables
    namelist /inputs/ nx, ny, total_time, Ra, Pr, beta, err, a_dif, a_adv, Tinit

    ! if parameter file is passed as command line argument, use this one
    if (command_argument_count() > 0) then
      call get_command_argument(1, input_file_name)
    end if
    print*, 'Reading inputs from ', input_file_name

    ! read inputs from file
    open(input_file_id, file=input_file_name)
    read(input_file_id, inputs)
    close(input_file_id)
    write(*, inputs) ! echo values to stdout

    this%total_time = total_time

  end subroutine

  subroutine initialize()
    implicit none
    ! local variables
    real :: width
    integer :: i

    h = 1.0 / ( ny - 1.0 ) ! mesh size
    width = ( nx - 1.0 ) / ( ny - 1.0 ) ! width

    ! compute diffusive timestep
    dt_dif = ( a_dif * min(h, h)**2 ) / max(k, Pr)

    ! allocate field arrays
    allocate(S(nx, ny), vx(nx, ny), vy(nx, ny), v(nx, ny))
    allocate(T(nx, ny), dT2(nx, ny), dTx(nx, ny), dTy(nx, ny), T_rhs(nx, ny))
    allocate(W(nx, ny), dW2(nx, ny), dWx(nx, ny), dWy(nx, ny), W_rhs(nx, ny))
    allocate(Ra_dTdx(nx, ny))

    S = 0.0; vx = 0.0; vy = 0.0; v = 0.0
    T = 0.0; dT2 = 0.0; dTx = 0.0; dTy = 0.0; T_rhs = 0.0
    W = 0.0; dW2 = 0.0; dWx = 0.0; dWy = 0.0; W_rhs = 0.0
    Ra_dTdx = 0.0

    ! initialize temperature T
    if (Tinit == 'cosine') then
      do concurrent (i=1:nx)
        T(i, :) = 0.5 * ( 1.0 + cos((3.0*pi*(i-1)*h)/width) )
      end do
    else
      call random_number(T)
    end if

    ! randomly initialize vorticity W
    call random_number(W)

    ! open velocity file
    open(v_file_id, file='v.bin', form='unformatted', access='stream')

  end subroutine initialize

  subroutine evolve(this, time)
    implicit none
    ! arguments
    class(simulation), intent(inout) :: this
    real, intent(in) :: time
    ! local variables
    real :: r_rms, v_max, c

    ! solve for stream function S: D S = W (Dirichlet BCs = 0)
    r_rms = MGsolve_2DPoisson(S, W, h, 0.0, err, niters, .false.)

    ! compute velocity field (vx, vy) from stream function S
    call compute_velocity(S, h, h, vx, vy)

    ! compute velocity magnitude v
    v = sqrt(vx**2 + vy**2)
    v_max = maxval(v)
    write(v_file_id) time, v_max

    ! compute timestep dt
    this%dt = compute_dt(v_max)

    ! apply boundary conditions
    call apply_boundary_conditions(T)

    ! compute Ra * dT / dx
    Ra_dTdx(2:nx-1, 2:ny-1) = Ra * ( ( T(3:nx, 2:ny-1) - T(1:nx-2, 2:ny-1) ) / (2 * h) )

    ! diffusion terms for temperature T and vorticity W
    if (beta /= 1.0) then
      dT2 = diffusion2d(T, h, k)
      dW2 = diffusion2d(W, h, Pr)
    end if

    ! advection terms for temperature T and vorticity W
    dTx = advection2dx(T, h, vx)
    dTy = advection2dy(T, h, vy)
    dWx = advection2dx(W, h, vx)
    dWy = advection2dy(W, h, vy)

    ! Euler step for temperature T and vorticity W
    if (beta > 0.0) then
      ! semi-implicit step for temperature T
      c = 1.0 / (beta * this%dt)
      T_rhs = -c * ( T + this%dt * ( (1.0 - beta) * dT2 - dTx - dTy ) )
      r_rms = MGsolve_2DPoisson(T, T_rhs, h, c, err, niters, .true.)
      ! semi-implicit step for vorticity W
      c = c / Pr
      W_rhs = -c * ( W + this%dt * ( (1.0 - beta) * dW2 - dWx - dWy - Pr * Ra_dTdx ) )
      r_rms = MGsolve_2DPoisson(W, W_rhs, h, c, err, niters, .false.)
    else
      ! explicit step for temperature T and vorticity W
      T = T + this%dt * ( dT2 - dTx - dTy )
      W = W + this%dt * ( dW2 - dWx - dWy - Pr * Ra_dTdx )
    end if

  end subroutine evolve

  real function compute_dt(v_max) result(dt_)
    implicit none
    ! arguments
    real, intent(in)  :: v_max

    if (v_max == 0.0) then
      ! set timestep equal to diffusive timestep (avoid division by zero)
      dt_ = dt_dif
    else
      ! compute advective timestep
      dt_adv = a_adv * min(h / maxval(vx), h / maxval(vy))
      ! compute timestep
      if (beta >= 0.5) then
        dt_ = dt_adv ! allow big diffusive timesteps
      else
        dt_ = min(dt_dif, dt_adv)
      end if
    end if

  end function compute_dt

  subroutine export_results()
    implicit none

    ! print final S to file
    open(S_file_id, file='S.bin', form='unformatted', access='stream')
    write (S_file_id) nx, ny, S
    close(S_file_id)

    ! print final W to file
    open(W_file_id, file='W.bin', form='unformatted', access='stream')
    write (W_file_id) nx, ny, W
    close(W_file_id)

    ! print final T to file
    open(T_file_id, file='T.bin', form='unformatted', access='stream')
    write (T_file_id) nx, ny, T
    close(T_file_id)

  end subroutine export_results

  subroutine destroy()
    implicit none

    ! close velocity file
    close(v_file_id)
    ! deallocate field arrays
    deallocate(S, vx, vy, v)
    deallocate(T, dT2, dTx, dTy, T_rhs)
    deallocate(W, dW2, dWx, dWy, W_rhs)
    deallocate(Ra_dTdx)

  end subroutine destroy

end module m_sim


!================cosmology-models=====================!
!for a better presentation of the code, each cosmology
!will have their own module, were their respective
!equation of satete and the needed variables will be
!computed, note that all modules must have the same structure:
!
!*) Equation of state
!*) Present data
!*) Splines
!=====================================================!

MODULE non_abelian_cosmology
  USE nrtype
  IMPLICIT NONE
  PUBLIC

  !the variable spline model, is to chek is the model has
  !spline or not, 1=yes, 0=no

  !=======Global_spine_variable=========!
  INTEGER, PARAMETER :: Spline_model=1
  Integer, PARAMETER :: Number_of_splines=200

  !========Eos-spline-varibles==========!
  INTEGER, PARAMETER :: EOS_nsplines=Number_of_splines
  REAL(rt), DIMENSION(EOS_nsplines) :: vec_w, vec_lna, vec_wpp
  INTEGER :: spline_flag0=1,spline_flagf=1 ! flag for the boundaries

  !=======w_integral-spline-variables=====!
  INTEGER, PARAMETER :: intEOS_nsplines=Number_of_splines
  REAL(rt), DIMENSION(intEOS_nsplines) :: vec_IntEos, vec_t!values and times of evaluation
  REAL(rt), DIMENSION(intEOS_nsplines) :: vec_IntEos_p,vec_IntEos_pp ! first and second derivatives!

  !========model-parameters=========!
  !
  REAL(rt) :: alpha=1.0e9_rt
  Real(rt) :: omegai=3.0e-27_rt !MASSLESS case on
  Real(rt) :: xi=3.0e-30_rt
  Real(rt) :: yi=0.0010_rt
  real(rt) :: zi=1.1e5_rt !~field
  real(rt) :: omega_ri=0.99998_rt !initial radiation density
  real(rt) :: z0=1.74e8_rt !initial redshift

CONTAINS

  !EOS := equation of state for the model
  ! althought evol_var returns those quantities
  ! we need this for the integration of the g(a)
  ! process

   Real(rt) FUNCTION EOS(lna)
    REAL(rt) :: lna
    REAL(rt) :: matter,radiation,dark_e,W,wp ! ancila data

    CALL evol_var(lna,matter,radiation,dark_e,w,wp)
    Eos=w

  END FUNCTION EOS

  !w_integral: implementation of the integral of the equation
  !of state, notice that we are integrating w(lna), so the equation of state
  !must be put in this way, w_integral=int(w/a da)

  SUBROUTINE w_integral(lna,wa_int)

    REAL(rt) :: lna,wa_int

    !======variables for the integration=====!
    INTEGER :: kf, iflag !flag and number of steps
    REAL(rt) :: t0,tf
    REAL(rt) :: eps=DSqrt(EPSILON(eps)) ! precission
    REAL(rt) :: wa_int_error ! error of the integration

    t0=0.0_rt  !ln(a=1), collapse now!!
    tf=lna ! evaluation of g(a)

    CALL q1da(EOS,t0,tf,eps,wa_int,wa_int_error,kf,iflag)

  END SUBROUTINE w_integral

  !Dynamic_eq:= equations of motion for the cosmological model

  SUBROUTINE Dynamic_eq(lna,z,dz_out)

    !====Variables of the subroutine======!
    REAL(rt) :: lna
    REAL(rt), DIMENSION(5) :: z,dz_out
    Real(rt) :: q

    !conventions:
    !z(1)-->x, z(2)-->y
    !z(3)-->w, z(4)-->z, z(5)-->rho_r

    !IMPORTANT: IF WE WANT THE MASSLESS CASE, TURN dz_out(3):=dw=0!
    !           AND SET THE INITIAL VALUE OF W=0
    !The equations are those in the mathematica nb.file

    q=(1 + z(2)**2 - z(3)**2 + (z(1)**2)*(1 - 12*alpha*(z(4)**4)) + z(5))/2.

    dz_out(1)=q*z(1) - ((2*(z(2)**2))/z(4) + 8*alpha*(z(1)**2)*(z(4)**3) +&
                         z(1)*(1 - 12*alpha*(z(4)**4)) )/(1 + 4*alpha*(z(4)**4))

    dz_out(2)=z(2)*(-1.0_rt + q + (2*z(1))/z(4))

    dz_out(3)=z(3)*(q + (z(1)/z(4))) !MASSLESS case off
    !dz_out(3)=0.0_rt !MASSLESS case on

    dz_out(4)=z(1)-z(4)

    dz_out(5)=2*(-1.0_rt + q)*z(5)

  END SUBROUTINE Dynamic_eq

  !presnt data:= computes de values of m0_density, r0_density, and
  !de0_density, in the diff_model the curvature is set to zero

  SUBROUTINE present_data(m0_rho,r0_rho,de0_rho,k0_rho)

    REAL(rt) :: m0_rho,r0_rho,de0_rho,k0_rho
    REAL(rt) :: w,wp !auxiliar variable for the call
    CALL evol_var(0.0_rt,m0_rho,r0_rho,de0_rho,w,wp)
    k0_rho=0.0_rt

  END SUBROUTINE present_data

  !evol_var: computes de evolution of the density parameters and the
  !equantion of state at the desired time lna

  SUBROUTINE evol_var(lna,m_density,r_density,de_density,w,dw_dlna)

    REAL(rt) :: lna
    REAL(rt) :: w,q !w(lna) output value of the eos
    REAL(rt) :: dw_dlna ! derivative of the eos
    REAL(rt) :: m_density,r_density,de_density ! output values of densities

    !====varibles for the call of the diff_equation===!
    REAL(rt), ALLOCATABLE :: z(:),dz(:)
    REAL(rt) :: t0,tf
    INTEGER :: flag
    REAL(rt) :: r_error,abs_error

    !==auxial_variables derivative of W==========!
    real(rt) :: num,dem
    real(rt) :: d_num,d_dem

    !=====initialization

    ALLOCATE(z(5),dz(5))

    r_error=DSqrt(EPSILON(r_error))
    abs_error=DSqrt(EPSILON(abs_error))

    flag=1

    !=====initialization values for one of the proposed in the paper========!
    t0=DLog(1.0_rt/(1.0_rt+z0))
    tf=lna
    z(1)=xi
    z(2)=yi
    z(3)=DSqrt(omegai)*zi
    z(4)=zi
    z(5)=omega_ri

    CALL Dynamic_eq(t0,z,dz)

    CALL r8_rkf45(Dynamic_eq,5,z,dz,t0,tf,r_error,abs_error,flag)

    m_density=1 - z(2)**2 - z(3)**2 - z(1)**2*(1 + 4*alpha*z(4)**4) - z(5)
    r_density=z(5)
    de_density=z(1)**2 + z(2)**2 + z(3)**2 + (4*alpha*(z(1)**2)*(z(4)**4))
    q=(1 + z(2)**2 - z(3)**2 + z(1)**2*(1 - 12*alpha*z(4)**4) + z(5))/2.

    !w=(z(1)**2 - 12*alpha*(z(1)**2)*(z(4)**4) + z(2)**2 -z(3)**2)/de_density
    !w=w/3

    w=(1/3.)*((z(1)**2)*(1-(12*alpha*(z(4)**4)))+(z(2)**2)-(z(3)**2))/&
       ((z(1)**2)*(1+(4*alpha*(z(4)**4)))+(z(2)**2)+(z(3)**2))

    d_num=(2*z(2)*dz(2))-(2*z(3)*dz(3))+(2*z(1)*dz(1)*(1 - 12*alpha*(z(4)**4)))&
           -((z(1)**2)*48*alpha*(z(4)**3)*dz(4))

    d_dem=(2*z(2)*dz(2))+(2*z(3)*dz(3))+(2*z(1)*dz(1)*(1 + 4*alpha*(z(4)**4)))&
           +((z(1)**2)*16*alpha*(z(4)**3)*dz(4))

    num=((z(1)**2)*(1-(12*alpha*(z(4)**4)))+(z(2)**2)-(z(3)**2))

    dem=((z(1)**2)*(1+(4*alpha*(z(4)**4)))+(z(2)**2)+(z(3)**2))

    dw_dlna=(1/3.0_rt)*((d_num*dem)-(d_dem*num))/(dem**2)

    !check the constraints....
    !write(*,*) "check: ", w,z(3)

    DEALLOCATE(z,dz)

  END SUBROUTINE evol_var

  !============splined=================!

  SUBROUTINE EOS_Spline_initialization(Aux_vec_t,Aux_vec,Aux_vec_pp)

    INTEGER :: i_val
    REAL(rt) :: t0,tf,dt
    REAL(rt) :: dx,dy,dw,w,wp ! ancila data

    REAL(rt) :: wp_0,wp_f !derivatives of the eos at the edges

    !==============definition of the input vectors========!
    REAL(rt),DIMENSION(EOS_nsplines) :: Aux_vec_t,Aux_vec,Aux_vec_pp
    Aux_vec_t=0.0_rt
    Aux_vec=0.0_rt
    Aux_vec_pp=0.0_rt
    !====================================================!

    !initialization of vec_w
    WRITE(*,*)"           "
    WRITE(*,*)"EOS_SPLINE INITIALIZATION..."

    t0=DLog(1.0_rt/(1.0_rt+z0))
    tf=0.0_rt
    dt=(tf-t0)/REAL(EOS_nsplines-1,kind=8)

    DO i_val=1,EOS_nsplines
       vec_lna(i_val)=t0+REAL(i_val-1,kind=8)*dt
       CALL evol_var(vec_lna(i_val),dx,dy,dw,w,wp)
       vec_w(i_val)=w
    END DO

    spline_flag0=1
    spline_flagf=1

    !Boundary conditions at the edges of the interval
    !================================================!
    CALL evol_var(t0,dx,dy,dw,w,wp)
    wp_0=wp
    CALL evol_var(tf,dx,dy,dw,w,wp)
    wp_f=wp
    !================================================!

    CALL spline_cubic_set(EOS_nsplines,vec_lna,vec_w,spline_flag0, &
         wp_0,spline_flagf,wp_f,vec_wpp)

    !==========this is where we take the information back=======!
    Aux_vec_t=vec_lna
    Aux_vec=vec_w
    Aux_vec_pp=vec_wpp
    !==========================================================!

    WRITE(*,*)"EOS_SPLINE: check"

  END SUBROUTINE EOS_Spline_initialization

  !int_EOS_spline_initialization:= spline for the integral...
  SUBROUTINE int_EOS_spline_initialization(Aux_vec_t,Aux_vec,Aux_vec_pp)

    INTEGER :: i_val
    REAL(rt) :: t0,tf,dt
    REAL(rt) :: int_w

    INTEGER :: intEOs_flag0,intEOs_flagf
    REAL(rt) :: Eos_f, Eos_0 ! edges derivatives

    !==============definition of the input vectors========!
    REAL(rt),DIMENSION(intEOS_nsplines) :: Aux_vec_t,Aux_vec,Aux_vec_pp
    Aux_vec_t=0.0_rt
    Aux_vec=0.0_rt
    Aux_vec_pp=0.0_rt
    !=====================================================!

    WRITE(*,*)"           "
    WRITE(*,*)"Int_EOS_SPLINE INITIALIZATION..."

    t0=DLog(1.0_rt/(1.0_rt+z0))
    tf=0.0_rt
    dt=(tf-t0)/REAL(intEOS_nsplines-1,kind=8)

    DO i_val=1,intEOS_nsplines
       vec_t(i_val)=t0+REAL(i_val-1,kind=8)*dt
       CALL w_integral(vec_t(i_val),int_w)
       vec_IntEos(i_val)=int_w
    END DO

    intEOs_flag0=1
    intEOs_flagf=1

    Eos_0=Eos(t0)
    Eos_f=Eos(tf)

    CALL spline_cubic_set(intEOS_nsplines,vec_t,vec_IntEos,intEos_flag0, &
         Eos_0,intEos_flagf,Eos_f,vec_IntEos_pp)

    !==========Assignaments==================!
    Aux_vec_t=vec_t
    Aux_vec=vec_IntEos
    Aux_vec_pp=vec_IntEos_pp
    !========================================!

    WRITE(*,*)"Int_EOS_SPLINE: check"
    WRITE(*,*)"             "

  END SUBROUTINE int_EOS_spline_initialization

END MODULE non_abelian_cosmology

MODULE two_form_cosmology
  USE nrtype
  IMPLICIT NONE
  PUBLIC

  !the variable spline model, is to chek is the model has
  !spline or not, 1=yes, 0=no

  !=======Global_spine_variable=========!
  INTEGER, PARAMETER :: Spline_model=1
  Integer, PARAMETER :: Number_of_splines=200

  !========Eos-spline-varibles==========!
  INTEGER, PARAMETER :: EOS_nsplines=Number_of_splines
  REAL(rt), DIMENSION(EOS_nsplines) :: vec_w, vec_lna, vec_wpp
  INTEGER :: spline_flag0=1,spline_flagf=1 ! flag for the boundaries

  !=======w_integral-spline-variables=====!
  INTEGER, PARAMETER :: intEOS_nsplines=Number_of_splines
  REAL(rt), DIMENSION(intEOS_nsplines) :: vec_IntEos, vec_t!values and times of evaluation
  REAL(rt), DIMENSION(intEOS_nsplines) :: vec_IntEos_p,vec_IntEos_pp ! first and second derivatives!

  !========model-parameters=========!
  REAL(rt) :: lambda=2.0_rt
  REAL(rt) :: mu=5.5_rt
  Real(rt) :: x1=1.0e-13_rt
  Real(rt) :: x2=1.0e-14_rt
  real(rt) :: sigma=0
  real(rt) :: omega_b=1.0e-10_rt
  real(rt) :: omega_r=0.999961
  real(rt) :: z0=4.5e7_rt !initial redshift for the lmanda and mu, values

CONTAINS

  !EOS := equation of state for the model
  ! althought evol_var returns those quantities
  ! we need this for the integration of the g(a)
  ! process

   Real(rt) FUNCTION EOS(lna)
    REAL(rt) :: lna
    REAL(rt) :: matter,radiation,dark_e,W,wp ! ancila data

    CALL evol_var(lna,matter,radiation,dark_e,w,wp)

    Eos=w
  END FUNCTION EOS

  !w_integral: implementation of the integral of the equation
  !of state, notice that we are integrating w(lna), so the equation of state
  !must be put in this way, w_integral=int(w/a da)

  SUBROUTINE w_integral(lna,wa_int)

    REAL(rt) :: lna,wa_int

    !======variables for the integration=====!
    INTEGER :: kf, iflag !flag and number of steps
    REAL(rt) :: t0,tf
    REAL(rt) :: eps=DSqrt(EPSILON(eps)) ! precission
    REAL(rt) :: wa_int_error ! error of the integration

    t0=0.0_rt  !ln(a=1), collapse now!!
    tf=lna ! evaluation of g(a)

    CALL q1da(EOS,t0,tf,eps,wa_int,wa_int_error,kf,iflag)

  END SUBROUTINE w_integral

  !Dynamic_eq:= equations of motion for the cosmological model

  SUBROUTINE Dynamic_eq(lna,z,dz_out)

    !====Variables of the subroutine======!
    REAL(rt) :: lna
    REAL(rt), DIMENSION(5) :: z,dz_out

    !lna=0.0_rt !the condition for an autonomous system

    !conventions:
    !z(1)-->x_1, z(2)-->x_2
    !z(3)-->Sigma, z(4)-->rho_b, z(5)-->rho_r

    dz_out(1)=(3.0_rt/2)*z(1)*((z(1)**2)-(z(2)**2)+(z(3)**2)-1.0_rt &
         -((1.0_rt/3)*z(4))+((1.0_rt/3)*z(5))) &
         +(DSqrt(6.0_rt)/2)*((lambda*(z(2)**2))-(mu*z(4)))

    dz_out(2)=(1.0_rt/2)*z(2)*(3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)+1.0_rt) &
         -(DSqrt(6.0_rt)*lambda*z(1))-z(4)+z(5))

    dz_out(3)=((1.0_rt/2)*z(3)*(3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)-1.0_rt) &
         -z(4)+z(5)))-2.0_rt*z(4)

    dz_out(4)=z(4)*((3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)))+(4.0_rt*z(3)) &
         +1.0_rt+(DSqrt(6.0_rt)*mu*z(1))-z(4)+z(5))

    dz_out(5)=z(5)*((3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)))-1.0_rt-z(4)+z(5))

  END SUBROUTINE Dynamic_eq

  !presnt data:= computes de values of m0_density, r0_density, and
  !de0_density, in the diff_model the curvature is set to zero

  SUBROUTINE present_data(m0_rho,r0_rho,de0_rho,k0_rho)

    REAL(rt) :: m0_rho,r0_rho,de0_rho,k0_rho
    REAL(rt) :: w,wp !auciliary variable for the call
    CALL evol_var(0.0_rt,m0_rho,r0_rho,de0_rho,w,wp)
    k0_rho=0.0_rt

  END SUBROUTINE present_data

  !evol_var: computes de evolution of the density parameters and the
  !equantion of state at the desired time lna

  SUBROUTINE evol_var(lna,m_density,r_density,de_density,w,dw_dlna)

    REAL(rt) :: lna
    REAL(rt) :: w !w(lna) output value of the eos
    REAL(rt) :: dw_dlna ! derivative of the eos
    REAL(rt) :: m_density,r_density,de_density ! output values of densities

    !====varibles for the call of the diff_equation===!
    REAL(rt), ALLOCATABLE :: z(:),dz(:)
    REAL(rt) :: t0,tf
    INTEGER :: flag
    REAL(rt) :: r_error,abs_error

    !=====initialization

    ALLOCATE(z(5),dz(5))

    r_error=DSqrt(EPSILON(r_error))
    abs_error=DSqrt(EPSILON(abs_error))

    flag=1

    !=====initialization values for one of the proposed in the paper========!
    t0=DLog(1.0_rt/(1.0_rt+z0))

    tf=lna
    z(1)=x1
    z(2)=x2
    z(3)=sigma
    z(4)=omega_b
    z(5)=omega_r

    CALL Dynamic_eq(t0,z,dz)

    CALL r8_rkf45(Dynamic_eq,5,z,dz,t0,tf,r_error,abs_error,flag)

    m_density=1.0_rt-(z(1)**2)-(z(2)**2)-(z(3)**2)-z(4)-z(5)
    r_density=z(5)
    de_density=1.0_rt-m_density-r_density

    w=(3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)))-z(4)
    w=w/(3.0_rt*((z(1)**2)+(z(2)**2)+(z(3)**2)+z(4)))

    dw_dlna=(6.0_rt*((z(1)*dz(1))-(z(2)*dz(2))+(z(3)*dz(3))))-dz(4)
    dw_dlna=dw_dlna*(3.0_rt*((z(1)**2)+(z(2)**2)+(z(3)**2)+z(4)))
    dw_dlna=dw_dlna-((6.0_rt*((z(1)*dz(1))+(z(2)*dz(2))+(z(3)*dz(3)))+3.0_rt*dz(4))*&
         (3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2))-z(4)))
    dw_dlna=dw_dlna/((3.0_rt*((z(1)**2)+(z(2)**2)+(z(3)**2)+z(4)))**2)

    DEALLOCATE(z,dz)

  END SUBROUTINE evol_var

  !============splined=================!

  SUBROUTINE EOS_Spline_initialization(Aux_vec_t,Aux_vec,Aux_vec_pp)

    INTEGER :: i_val
    REAL(rt) :: t0,tf,dt
    REAL(rt) :: dx,dy,dw,w,wp ! ancila data

    REAL(rt) :: wp_0,wp_f !derivatives of the eos at the edges

    !==============definition of the input vectors========!
    REAL(rt),DIMENSION(EOS_nsplines) :: Aux_vec_t,Aux_vec,Aux_vec_pp
    Aux_vec_t=0.0_rt
    Aux_vec=0.0_rt
    Aux_vec_pp=0.0_rt
    !====================================================!

    !initialization of vec_w
    WRITE(*,*)"           "
    WRITE(*,*)"EOS_SPLINE INITIALIZATION..."

    t0=DLog(1.0_rt/(1.0_rt+z0))
    tf=0.0_rt
    dt=(tf-t0)/REAL(EOS_nsplines-1,kind=8)

    DO i_val=1,EOS_nsplines
       vec_lna(i_val)=t0+REAL(i_val-1,kind=8)*dt
       CALL evol_var(vec_lna(i_val),dx,dy,dw,w,wp)
       vec_w(i_val)=w
    END DO

    spline_flag0=1
    spline_flagf=1

    !Boundary conditions at the edges of the interval
    !================================================!
    CALL evol_var(t0,dx,dy,dw,w,wp)
    wp_0=wp
    CALL evol_var(tf,dx,dy,dw,w,wp)
    wp_f=wp
    !================================================!

    CALL spline_cubic_set(EOS_nsplines,vec_lna,vec_w,spline_flag0, &
         wp_0,spline_flagf,wp_f,vec_wpp)

    !==========this is where we take the information back=======!
    Aux_vec_t=vec_lna
    Aux_vec=vec_w
    Aux_vec_pp=vec_wpp
    !==========================================================!

    WRITE(*,*)"EOS_SPLINE: check"

  END SUBROUTINE EOS_Spline_initialization

  !int_EOS_spline_initialization:= spline for the integral...
  SUBROUTINE int_EOS_spline_initialization(Aux_vec_t,Aux_vec,Aux_vec_pp)

    INTEGER :: i_val
    REAL(rt) :: t0,tf,dt
    REAL(rt) :: int_w

    INTEGER :: intEOs_flag0,intEOs_flagf
    REAL(rt) :: Eos_f, Eos_0 ! edges derivatives

    !==============definition of the input vectors========!
    REAL(rt),DIMENSION(intEOS_nsplines) :: Aux_vec_t,Aux_vec,Aux_vec_pp
    Aux_vec_t=0.0_rt
    Aux_vec=0.0_rt
    Aux_vec_pp=0.0_rt
    !=====================================================!

    WRITE(*,*)"           "
    WRITE(*,*)"Int_EOS_SPLINE INITIALIZATION..."

    t0=DLog(1.0_rt/(1.0_rt+z0))
    tf=0.0_rt
    dt=(tf-t0)/REAL(intEOS_nsplines-1,kind=8)

    DO i_val=1,intEOS_nsplines
       vec_t(i_val)=t0+REAL(i_val-1,kind=8)*dt
       CALL w_integral(vec_t(i_val),int_w)
       vec_IntEos(i_val)=int_w
    END DO

    intEOs_flag0=1
    intEOs_flagf=1

    Eos_0=Eos(t0)
    Eos_f=Eos(tf)

    CALL spline_cubic_set(intEOS_nsplines,vec_t,vec_IntEos,intEos_flag0, &
         Eos_0,intEos_flagf,Eos_f,vec_IntEos_pp)

    !==========Assignaments==================!
    Aux_vec_t=vec_t
    Aux_vec=vec_IntEos
    Aux_vec_pp=vec_IntEos_pp
    !========================================!

    WRITE(*,*)"Int_EOS_SPLINE: check"
    WRITE(*,*)"             "

  END SUBROUTINE int_EOS_spline_initialization

END MODULE two_form_cosmology

MODULE one_form_cosmology
  USE nrtype
  IMPLICIT NONE
  PUBLIC

  !the variable spline model, is to chek is the model has
  !spline or not, 1=yes, 0=no

  !=======Global_spine_variable=========!
  INTEGER, PARAMETER :: Spline_model=1
  Integer, PARAMETER :: Number_of_splines=500

  !========Eos-spline-varibles==========!
  INTEGER, PARAMETER :: EOS_nsplines=Number_of_splines !number of knots
  REAL(rt), DIMENSION(EOS_nsplines) :: vec_w, vec_lna, vec_wpp
  INTEGER :: spline_flag0=1,spline_flagf=1 ! flag for the boundaries

  !=======w_integral-spline-variables=====!
  INTEGER, PARAMETER :: intEOS_nsplines=Number_of_splines ! number of splines
  REAL(rt), DIMENSION(intEOS_nsplines) :: vec_IntEos, vec_t!values and times of evaluation
  REAL(rt), DIMENSION(intEOS_nsplines) :: vec_IntEos_p,vec_IntEos_pp ! first and second derivatives!

  !========model-parameters=========!
  REAL(rt) :: lambda=2.0_rt
  REAL(rt) :: mu=5.0_rt
  real(rt) :: z0=5.5e7_rt

CONTAINS

  !EOS := equation of state for the model
  ! althought evol_var returns those quantities
  ! we need this for the integration of the g(a)
  ! process

  REAL(rt) FUNCTION EOS(lna)
    REAL(rt) :: lna
    REAL(rt) :: dx,dy,dw,w,wp ! ancila data

    CALL evol_var(lna,dx,dy,dw,w,wp)

    EOS=w
  END FUNCTION EOS

  !w_integral: implementation of the integral of the equation
  !of state, notice that we are integrating w(lna), so the equation of state
  !must be put in this way, w_integral=int(w/a da)

  SUBROUTINE w_integral(lna,wa_int)

    REAL(rt) :: lna,wa_int

    !======variables for the integration=====!
    INTEGER :: kf, iflag !flag and number of steps
    REAL(rt) :: t0,tf
    REAL(rt) :: eps=DSqrt(EPSILON(eps)) ! precission
    REAL(rt) :: wa_int_error ! error of the integration

    t0=0.0_rt  !ln(a=1), collapse now!!
    tf=lna ! evaluation of g(a)

    CALL q1da(EOS,t0,tf,eps,wa_int,wa_int_error,kf,iflag)

  END SUBROUTINE w_integral

  !Dynamic_eq:= equations of motion for the cosmological model

  SUBROUTINE Dynamic_eq(lna,z,dz_out)

    !====Variables of the subroutine======!
    REAL(rt) :: lna
    REAL(rt), DIMENSION(5) :: z,dz_out

    lna=0.0_rt !the condition for an autonomous system

    !conventions:
    !z(1)-->X, z(2)-->Y
    !z(3)-->Sigma, z(4)-->Omega_1, z(5)-->Omega_r

    dz_out(1)=(3.0_rt/2)*z(1)*((z(1)**2)-(z(2)**2)+(z(3)**2)-1.0_rt &
         +((1.0_rt/3)*z(4))+((1.0_rt/3)*z(5))) &
         +(DSqrt(6.0_rt)/2)*((lambda*(z(2)**2))-(2.0_rt*mu*z(4)))

    dz_out(2)=(1.0_rt/2)*z(2)*(3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)+1.0_rt) &
         -(DSqrt(6.0_rt)*lambda*z(1))+z(4)+z(5))

    dz_out(3)=((1.0_rt/2)*z(3)*(3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)-1.0_rt) &
         +z(4)+z(5)))+2.0_rt*z(4)

    dz_out(4)=z(4)*((3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)))+(4.0_rt*z(3)) &
         -1.0_rt+(2.0_rt*DSqrt(6.0_rt)*mu*z(1))+z(4)+z(5))

    dz_out(5)=z(5)*((3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)))-1.0_rt+z(4)+z(5))

  END SUBROUTINE Dynamic_eq

  !presnt data:= computes de values of m0_density, r0_density, and
  !de0_density, in the diff_model the curvature is set to zero

  SUBROUTINE present_data(m0_rho,r0_rho,de0_rho,k0_rho)

    REAL(rt) :: m0_rho,r0_rho,de0_rho,k0_rho
    REAL(rt) :: w,wp !auciliary variable for the call
    CALL evol_var(0.0_rt,m0_rho,r0_rho,de0_rho,w,wp)
    k0_rho=0.0_rt

  END SUBROUTINE present_data

  !evol_var: computes de evolution of the density parameters and the
  !equantion of state at the desired time lna

  SUBROUTINE evol_var(lna,m_density,r_density,de_density,w,dw_dlna)

    REAL(rt) :: lna
    REAL(rt) :: w !w(lna) output value of the eos
    REAL(rt) :: dw_dlna ! derivative of the eos
    REAL(rt) :: m_density,r_density,de_density ! output values of densities

    !====varibles for the call of the diff_equation===!
    REAL(rt), ALLOCATABLE :: z(:),dz(:)
    REAL(rt) :: t0,tf
    INTEGER :: flag
    REAL(rt) :: r_error,abs_error

    !=====initialization

    ALLOCATE(z(5),dz(5))

    r_error=DSqrt(EPSILON(r_error))
    abs_error=DSqrt(EPSILON(abs_error))

    flag=1

    !=====initialization values for one of the proposed in the paper========!
    t0=DLog(1.0_rt/(1.0_rt+z0))
    tf=lna
    z(1)=1.0e-13_rt
    z(2)=1.0e-14_rt
    z(3)=0
    z(4)=1.0e-5_rt
    z(5)=0.999961
    CALL Dynamic_eq(t0,z,dz)

    CALL r8_rkf45(Dynamic_eq,5,z,dz,t0,tf,r_error,abs_error,flag)

    de_density=(z(1)**2)+(z(2)**2)+(z(3)**2)+z(4)
    r_density=z(5)
    m_density=1.0_rt-de_density-r_density

    w=(3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2)))+z(4)
    w=w/(3.0_rt*((z(1)**2)+(z(2)**2)+(z(3)**2)+z(4)))

    dw_dlna=(6.0_rt*((z(1)*dz(1))-(z(2)*dz(2))+(z(3)*dz(3))))+dz(4)
    dw_dlna=dw_dlna*(3.0_rt*((z(1)**2)+(z(2)**2)+(z(3)**2)+z(4)))
    dw_dlna=dw_dlna-((6.0_rt*((z(1)*dz(1))+(z(2)*dz(2))+(z(3)*dz(3)))+3.0_rt*dz(4))*&
         (3.0_rt*((z(1)**2)-(z(2)**2)+(z(3)**2))+z(4)))
    dw_dlna=dw_dlna/((3.0_rt*((z(1)**2)+(z(2)**2)+(z(3)**2)+z(4)))**2)

    DEALLOCATE(z,dz)

  END SUBROUTINE evol_var

  !============splined=================!

  SUBROUTINE EOS_Spline_initialization(Aux_vec_t,Aux_vec,Aux_vec_pp)

    INTEGER :: i_val
    REAL(rt) :: t0,tf,dt
    REAL(rt) :: dx,dy,dw,w,wp ! ancila data

    REAL(rt) :: wp_0,wp_f !derivatives of the eos at the edges

    !==============definition of the input vectors========!
    REAL(rt),DIMENSION(EOS_nsplines) :: Aux_vec_t,Aux_vec,Aux_vec_pp
    Aux_vec_t=0.0_rt
    Aux_vec=0.0_rt
    Aux_vec_pp=0.0_rt
    !====================================================!

    !initialization of vec_w
    WRITE(*,*)"           "
    WRITE(*,*)"EOS_SPLINE INITIALIZATION..."

    t0=DLog(1.0_rt/(1.0_rt+7.9e7_rt))
    tf=0.0_rt
    dt=(tf-t0)/REAL(EOS_nsplines-1,kind=8)

    DO i_val=1,EOS_nsplines
       vec_lna(i_val)=t0+REAL(i_val-1,kind=8)*dt
       CALL evol_var(vec_lna(i_val),dx,dy,dw,w,wp)
       vec_w(i_val)=w
    END DO

    spline_flag0=1
    spline_flagf=1

    !Boundary conditions at the edges of the interval
    !================================================!
    CALL evol_var(t0,dx,dy,dw,w,wp)
    wp_0=wp
    CALL evol_var(tf,dx,dy,dw,w,wp)
    wp_f=wp
    !================================================!

    CALL spline_cubic_set(EOS_nsplines,vec_lna,vec_w,spline_flag0, &
         wp_0,spline_flagf,wp_f,vec_wpp)

    !==========this is where we take the information back=======!
    Aux_vec_t=vec_lna
    Aux_vec=vec_w
    Aux_vec_pp=vec_wpp
    !==========================================================!

    WRITE(*,*)"EOS_SPLINE: check"

  END SUBROUTINE EOS_Spline_initialization

  !int_EOS_spline_initialization:= spline for the integral...
  SUBROUTINE int_EOS_spline_initialization(Aux_vec_t,Aux_vec,Aux_vec_pp)

    INTEGER :: i_val
    REAL(rt) :: t0,tf,dt
    REAL(rt) :: int_w

    INTEGER :: intEOs_flag0,intEOs_flagf
    REAL(rt) :: Eos_f, Eos_0 ! edges derivatives

    !==============definition of the input vectors========!
    REAL(rt),DIMENSION(intEOS_nsplines) :: Aux_vec_t,Aux_vec,Aux_vec_pp
    Aux_vec_t=0.0_rt
    Aux_vec=0.0_rt
    Aux_vec_pp=0.0_rt
    !=====================================================!

    WRITE(*,*)"           "
    WRITE(*,*)"Int_EOS_SPLINE INITIALIZATION..."

    t0=DLog(1.0_rt/(1.0_rt+7.9e7_rt))
    tf=0.0_rt
    dt=(tf-t0)/REAL(intEOS_nsplines-1,kind=8)

    DO i_val=1,intEOS_nsplines
       vec_t(i_val)=t0+REAL(i_val-1,kind=8)*dt
       CALL w_integral(vec_t(i_val),int_w)
       vec_IntEos(i_val)=int_w
    END DO

    intEOs_flag0=1
    intEOs_flagf=1

    Eos_0=Eos(t0)
    Eos_f=Eos(tf)

    CALL spline_cubic_set(intEOS_nsplines,vec_t,vec_IntEos,intEos_flag0, &
         Eos_0,intEos_flagf,Eos_f,vec_IntEos_pp)

    !==========Assignaments==================!
    Aux_vec_t=vec_t
    Aux_vec=vec_IntEos
    Aux_vec_pp=vec_IntEos_pp
    !========================================!

    WRITE(*,*)"Int_EOS_SPLINE: check"
    WRITE(*,*)"             "

  END SUBROUTINE int_EOS_spline_initialization

END MODULE one_form_cosmology

!====================================================
!.....EINSTEIN´S DE SITTER UNIVERSE.....
!====================================================

MODULE EDS_cosmology
  USE nrtype

  INTEGER, PARAMETER :: Spline_model=0

CONTAINS

  SUBROUTINE present_data(m0_rho,r0_rho,de0_rho,k0_rho)

    REAL(rt) :: m0_rho,r0_rho,de0_rho,k0_rho
    k0_rho=0.0_rt
    r0_rho=0.0_rt
    de0_rho=0.0_rt
    m0_rho=1.0_rt

  END SUBROUTINE present_data

  SUBROUTINE E_model_function(a,E_f,de_da)

    !==========initial_densities=======!
    REAL(rt) :: matter
    !=========input and output-parameters=========!
    REAL(rt) :: a,E_f,De_da

    matter=1.0_rt

    E_f=DSQRT(matter/(a**3.0_rt))
    de_da=(1.0_rt/2)*(1.0_rt/E_f)*(-3.0_rt*matter*(1/(a**4.0_rt)))

  END SUBROUTINE E_model_function

END MODULE EDS_cosmology

!====================================================
!....Lambda CDM cosmology.....
!====================================================

MODULE LCDM_cosmology
  USE nrtype

  INTEGER, PARAMETER :: spline_model=0
  real(rt), PARAMETER :: DE_today=0.6842_rt
  real(rt), PARAMETER :: M_today=0.3158_rt

  !0.750_rt  !0.6842_rt !planck 2018 values

CONTAINS

  SUBROUTINE present_data(m0_rho,r0_rho,de0_rho,k0_rho)

    REAL(rt) :: m0_rho,r0_rho,de0_rho,k0_rho
    k0_rho=0.0_rt
    r0_rho=0.0_rt
    de0_rho=DE_today
    m0_rho=M_today

  END SUBROUTINE present_data

  SUBROUTINE E_model_function(a,E_f,de_da)

    !==========initial_densities=======!
    REAL(rt) :: matter,d_energy

    !=========input and output-parameters=========!
    REAL(rt) :: a,E_f,De_da

    matter=M_today
    d_energy=DE_today

    E_f=DSQRT((matter/(a**3.0_rt))+d_energy)
    de_da=(1.0_rt/2)*(1.0_rt/E_f)*((-3.0_rt*matter*(1/(a**4.0_rt))))

  END SUBROUTINE E_model_function

END MODULE LCDM_cosmology

!====================================================
!====================================================
!....CASSIMIR cosmology.....
!====================================================
!====================================================

MODULE Cassimir_cosmology
  USE nrtype

  INTEGER, PARAMETER :: Spline_model=0
  real(rt), PARAMETER :: M_today=0.25_rt!0.3158_rt
  real(rt), PARAMETER :: DE_today=0.75_rt!0.6842_rt
  real(rt), PARAMETER :: cass_today=-0.00035

CONTAINS

  SUBROUTINE present_data(m0_rho,r0_rho,de0_rho,k0_rho)

    REAL(rt) :: m0_rho,r0_rho,de0_rho,k0_rho
    k0_rho=0.0_rt
    r0_rho=0.0_rt
    de0_rho=DE_today
    m0_rho=M_today

  END SUBROUTINE present_data

  real(rt) function Eos(lna)
    real(rt) :: lna,aux
    real(rt) :: d_energy, cassimir
    d_energy=DE_today
    cassimir=cass_today

    aux=(-1.0_rt/3)*((3.0_rt*d_energy*(Dexp(lna)**4))+Cassimir)/ &
        ((d_energy*(Dexp(lna)**4))-cassimir)

    Eos=aux

  end function eos

  SUBROUTINE E_model_function(a,E_f,de_da)

    !==========initial_densities=======!
    REAL(rt) :: matter,d_energy
    REAL(rt) :: Cassimir

    !=========input and output-parameters=========!
    REAL(rt) :: a,E_f,De_da

    matter=M_today
    d_energy=DE_today
    Cassimir=cass_today

    E_f=DSQRT((matter/(a**3.0_rt))+d_energy-(Cassimir/(a**4.0_rt)))
    de_da=(1.0_rt/2)*(1.0_rt/E_f)*((-3.0_rt*matter*(1/(a**4.0_rt)))+&
    (4.0_rt*cassimir/(a**5.0_rt)))

  END SUBROUTINE E_model_function

END MODULE Cassimir_cosmology


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      SUBROUTINE Matrix_Det(n,Matrix,det)
C     get det of matrix

      implicit none
      integer n
      double precision,intent(in)::Matrix(n,n)
      double precision,intent(out)::det

      double precision m,temp
      double precision temp_Matrix(n,n)

      INTEGER :: i, j, k, l

      !Flag to know if the matrix is singular
      LOGICAL :: DetExists = .TRUE.
      !l stores the sign change of the matrix in case there are row exchanges
      l = 1

      !====================================================================
      !                  Convert to upper triangular form
      !====================================================================
      temp_Matrix = Matrix

      !For each pivot row
      DO k = 1, n-1
          !If the pivot element is 0 then the matrix is probably singular
          !We'll need to exchange this row with another one which
          !has a nonzero pivot.
          IF (temp_Matrix(k,k) .eq. 0.0D0) THEN
			  DetExists = .FALSE.
			  !This DO loop searches for the nearest row with a non zero pivot. A better
			  !way would be to look for the largest non-zero pivot.
              DO i = k+1, n
				  !Check if the pivot is nonzero
				  !if it is, perform the row exchange
                  IF (temp_Matrix(i,k) /= 0.0D0) THEN
                      !This loop does the row exchange
                      DO j = 1, n
                          temp = temp_Matrix(i,j)
                          temp_Matrix(i,j)= temp_Matrix(k,j)
                          temp_Matrix(k,j) = temp
                      END DO
                      !Because we were able to find a non-zero pivot, the matrix
                      !may be non-singular so set the flag
                      DetExists = .TRUE.
                      !We'll need to change the sign because of the row exchange
                      !#Possible Bug#: I think the sign change should be outside
                      !the if
                      l=-l
                      !Exit the outer Do loop because we found a row we can exchange with
                      EXIT
                  END IF
              END DO
			  !If no row was found, the matrix is singular and we can stop here.
              IF (DetExists .EQV. .FALSE.) THEN
				det = 0
				return
              END IF
          END IF
          !This Do loop performs the row operations as per the Gauss elimination algorithm.
          DO j = k+1, n
			  !Find the correct multiple for the current row
			  m = temp_Matrix(j,k)/temp_Matrix(k,k)
			  !Subtract the pivot row from the current row.
              DO i = k+1, n
                   temp_Matrix(j,i) = temp_Matrix(j,i)
     &                             - m*temp_Matrix(k,i)
              END DO
          END DO
      END DO

      !====================================================================
      !     Calculate determinant by finding product of diagonal elements
      !====================================================================
      det = l
      DO i = 1, n
          det = det * temp_Matrix(i,i)
      END DO

      return
      END SUBROUTINE Matrix_Det


      Subroutine cgssor3(rhs,sol,n,m,nx)
!
!   Solves via PCG with SSOR preconditioner.
!   Uses sparse implementation on space grid.
!
      implicit none
      real*8 rhs(n,m)
      real*8 sol(n,m)
      real,dimension (0:nx+1,0:nx+1,1:m):: u,p,q,r,rhat
      real,dimension (0:nx+1) :: x,y
      real,dimension (1:m+1) :: oldrho, rho,alpha
      real :: error,dx2,w,time
      integer ::i,j,k,kk,n,nx,m,mcg
      w = 1.7
      u = 0.0
      kk = m
      r = 0.0
      rhat = 0.0
      q = 0.0
      p = 0.0
      do k = 1,kk
      do j = 1,nx
        do i = 1,nx
          r(i,j,k) = rhs(i+(j-1)*(nx),k)
        enddo
      enddo
      enddo
      error = 1.
      mcg = 0
      rho  = 0.0

      do while ((error>.0001).and.(mcg<200))
        mcg = mcg+1
        oldrho = rho
!	Execute SSOR preconditioner
        do k=1,kk
	do j= 1,nx
	  do i = 1,nx
	    rhat(i,j,k) = w*(r(i,j,k)+rhat(i-1,j,k)+rhat(i,j-1,k))*.25
	  enddo
	enddo
	enddo
	rhat(1:nx,1:nx,1:kk) =  ((2.-w)/w)*4.*rhat(1:nx,1:nx,1:kk)
	do k = 1,kk
	do j= nx,1,-1
	  do i = nx,1,-1
	  rhat(i,j,k) = w*(rhat(i,j,k)+rhat(i+1,j,k)+rhat(i,j+1,k))*.25
	  enddo
	enddo
	enddo
!	Find conjugate direction
	do k = 1,kk
        rho(k) = sum(r(1:nx,1:nx,k)*rhat(1:nx,1:nx,k))
        If (rho(k).ne.0.) then
        if (mcg.eq.1) then
          p(1:nx,1:nx,k) = rhat(1:nx,1:nx,k)
        else
          p(1:nx,1:nx,k) = rhat(1:nx,1:nx,k) +
     1     			(rho(k)/oldrho(k))*p(1:nx,1:nx,k)
        endif
!       Execute matrix product q = Ap
        q(1:nx,1:nx,k)=4.0*p(1:nx,1:nx,k)-p(0:nx-1,1:nx,k)-
     1   		p(2:nx+1,1:nx,k)
     1    		- p(1:nx,0:nx-1,k) - p(1:nx,2:nx+1,k)
!	Find steepest descent
        alpha(k) = rho(k)/sum(p(1:nx,1:nx,k)*q(1:nx,1:nx,k))
        u(1:nx,1:nx,k) = u(1:nx,1:nx,k) + alpha(k)*p(1:nx,1:nx,k)
        r(1:nx,1:nx,k) = r(1:nx,1:nx,k) - alpha(k)*q(1:nx,1:nx,k)
        endif
        enddo
        error = maxval(abs(r(1:nx,1:nx,1:kk)))
      enddo
      do k = 1,kk
      do j = 1,nx
        do i = 1,nx
          sol(i+(j-1)*(nx),k) = u(i,j,k)
        enddo
      enddo
      enddo
!      print*, mcg ,error
      end subroutine


program array_bound_1

    integer :: a(2:5, 3:9, 7)
    integer :: b(1:2, 2:4, 3:6, 4:7)
    integer :: c(6:10, 7)
    integer :: d(4)

    print *, lbound(a, 1), lbound(a, 2), lbound(a, 3)
    print *, ubound(a, 1), ubound(a, 2), ubound(a, 3)

    print *, lbound(b, 1), lbound(b, 2), lbound(b, 3), lbound(b, 4)
    print *, ubound(b, 1), ubound(b, 2), ubound(b, 3), ubound(b, 4)

    print *, lbound(c, 1), lbound(c, 2)
    print *, ubound(c, 1), ubound(c, 2)

    print *, lbound(d, 1)
    print *, ubound(d, 1)

end program array_bound_1


!> Precision 'dp' given by 'selected_real_kind(P,R).
!! where P is the precision ie. number of significant digits
!! and R is the range +- 10**R
!! standard single precision (32 bit), P=7, R = 38
!! double precision (64 bit),          P=15, R=308

module real_precision

  integer, parameter :: dp = selected_real_kind(15, 308)
!  integer, parameter :: dp = selected_real_kind(7, 38)

end module real_precision


! Fortran, rev. 1990 source code (Intel IFORT 17.0.1 compliant)
! Copyright (C) 2017, Emanuele Ballarin <emanuele@ballarin.cc>

! MODFOURCOLLATZ
! An efficient modulo-4 optimized Collatz Conjecture (in)validator

PROGRAM MODFOURCOLLATZ

    implicit none

    integer, parameter  :: ik = 8           ! For gfortran-5, 16 is still valid
    integer (kind = ik) :: current, maxchk, cnt, prechain

    integer (kind = ik) :: startfrom = 5    ! Select from where to start

    maxchk = startfrom - 1      ! Numbers before startfrom are assumed to be checked already
    prechain = startfrom

    ! Iterate on every positive integer after startfrom
    do while(.TRUE.)

        cnt = 0
        current = prechain

        ! Unroll the Collatz sequence until an already-checked number is found
        do while(current .GT. maxchk)

            cnt = cnt + 1
            select case (MOD(current, 4))
                case (0)
                    current = current/4
                case (1)
                    ! Optimization subcycle while the sequence is still === 1 MOD4
                    cnt = cnt - 1
                    do while ((MOD(current, 4) == 1) .AND. (current .GT. maxchk))
                        cnt = cnt + 1
                        current = (current - 1)/4
                    end do
                case (2)
                    current = current/2
                case (3)
                    current = (3*current + 1)/2

                case default    ! If this case is selected, there must be a problem
                    print*, 'BEWARE: Computation encountered an error...'
                    print*, 'Checked until ', maxchk
                    print*, 'Error detected while testing ', maxchk + 1, '; Chain-step ', current
                end select
        end do

        maxchk = maxchk + 1
        prechain = prechain + 1

        print*, 'Checked integer: ', maxchk, ' in ', cnt, ' steps'

    end do

END PROGRAM