module random_logical_mod
implicit none
contains
pure elemental function optval(x,default) result(y)
! modeled after Fortran stdlib optval
real, intent(in), optional :: x
real, intent(in)           :: default
real                       :: y
if (present(x)) then
   y = x
else
   y = default
end if
end function optval
!
subroutine random_logical_scalar(tf,prob)
! return logical variable that has probability prob
! of being .true., 0.5 if prob not PRESENT
logical, intent(out)          :: tf
real   , intent(in), optional :: prob
real                          :: x
call random_number(x)
tf = x < optval(prob,0.5)
end subroutine random_logical_scalar
!
subroutine random_logical_vec(tf,prob)
logical, intent(out)          :: tf(:)
real   , intent(in), optional :: prob
integer                       :: i
do i=1,size(tf)
! line below is valid since 2nd argument of callee is OPTIONAL
   call random_logical_scalar(tf(i),prob)
end do
end subroutine random_logical_vec
end module random_logical_mod
!
program test_random_logical
use random_logical_mod, only: random_logical_vec
implicit none
integer, parameter :: n = 1000
logical :: tf(n)
call random_logical_vec(tf)
print*,"fraction true =",count(tf)/real(n)
call random_logical_vec(tf,prob=0.9)
print*,"fraction true =",count(tf)/real(n)
end program test_random_logical
! sample output:
! fraction true =  0.500000000
! fraction true =  0.903999984


*DECK DVNORM
      DOUBLE PRECISION FUNCTION DVNORM (N, V, W)
C***BEGIN PROLOGUE  DVNORM
C***SUBSIDIARY
C***PURPOSE  Weighted root-mean-square vector norm.
C***TYPE      DOUBLE PRECISION (SVNORM-S, DVNORM-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  This function routine computes the weighted root-mean-square norm
C  of the vector of length N contained in the array V, with weights
C  contained in the array W of length N:
C    DVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 )
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890503  Minor cosmetic changes.  (FNF)
C   930809  Renamed to allow single/double precision versions. (ACH)
C***END PROLOGUE  DVNORM
C**End
      INTEGER N,   I
      DOUBLE PRECISION V, W,   SUM
      DIMENSION V(N), W(N)
C
C***FIRST EXECUTABLE STATEMENT  DVNORM
      SUM = 0.0D0
      DO 10 I = 1,N
 10     SUM = SUM + (V(I)*W(I))**2
      DVNORM = SQRT(SUM/N)
      RETURN
C----------------------- END OF FUNCTION DVNORM ------------------------
      END


	SUBROUTINE IS_INTX ( y1, x1, y2, x2, yy, xx, iret )
C************************************************************************
C* IS_INTX 								*
C*									*
C* This subroutine calculates the intersection point of two lines whose *
C* coordinates are latitudes and longitudes.                            *
C*                                                                      *
C* IS_INTX ( Y1, X1, Y2, X2, YY, XX, IRET )                             *
C*									*
C* Input parameters:							*
C*	Y1(*)		REAL		Latitude points of first line   *
C*	X1(*)		REAL		Longitude points of first line  *
C*	Y2(*)		REAL		Latitude points of second line  *
C*	X2(*)		REAL		Longitude points of second line *
C*									*
C* Output parameters:							*
C*	YY		REAL		Latitude point of intersection  *
C*	XX		REAL		Longitude point of intersection *
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = points not calculable     *
C*									*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	11/99	                                        *
C* D. Kidwell/NCEP	 1/00	Added error check                       *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		y1 (*), x1 (*), y2 (*), x2 (*)
C*
	REAL		xx1 (2), xx2 (2)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	yy   = RMISSD
	xx   = RMISSD
C
	DO ii = 1, 2
	    xx1 ( ii ) = x1 ( ii )
	    xx2 ( ii ) = x2 ( ii )
	    IF ( xx1 ( ii ) .lt. 0. ) xx1 ( ii ) = xx1 ( ii ) + 360.
	    IF ( xx2 ( ii ) .lt. 0. ) xx2 ( ii ) = xx2 ( ii ) + 360.
	END DO
C
	IF ( xx1 ( 1 ) .eq. xx1 ( 2 ) ) THEN
	    xx = xx1 ( 1 )
	    IF ( xx2 ( 1 ) .ne. xx2 ( 2 ) ) THEN
		s2 = ( y2 ( 2 ) - y2 ( 1 ) ) / ( xx2 ( 2 ) - xx2 ( 1 ) )
		b2 = y2 ( 1 ) - s2 * xx2 ( 1 )
		yy = s2 * xx + b2
	    END IF
	  ELSE IF ( xx2 ( 1 ) .eq. xx2 ( 2 ) ) THEN
	    xx = xx2 ( 1 )
	    s1 = ( y1 ( 2 ) - y1 ( 1 ) ) / ( xx1 ( 2 ) - xx1 ( 1 ) )
	    b1 = y1 ( 1 ) - s1 * xx1 ( 1 )
	    yy = s1 * xx + b1
	  ELSE
	    s1 = ( y1 ( 2 ) - y1 ( 1 ) ) / ( xx1 ( 2 ) - xx1 ( 1 ) )
	    b1 = y1 ( 1 ) - s1 * xx1 ( 1 )
	    s2 = ( y2 ( 2 ) - y2 ( 1 ) ) / ( xx2 ( 2 ) - xx2 ( 1 ) )
	    b2 = y2 ( 1 ) - s2 * xx2 ( 1 )
	    IF ( s1 .ne. s2 ) THEN
		xx = ( b2 - b1 ) / ( s1 - s2 )
		yy = s1 * xx + b1
	    END IF
	END IF
	IF ( xx .gt. 180. ) xx = xx - 360.
	IF ( ( ERMISS ( xx ) ) .or. ( ERMISS ( yy ) ) ) iret = -1
C*
	RETURN
	END


module m_random3
contains
subroutine random3(work1,n_var,n_ens)
! Returns a vector of normal (Gaussian) random numbers N(mean=0,variance=1)
!
  implicit none
  integer             :: i,j
  integer,intent(in)  :: n_var,n_ens
  real(8),intent(out) :: work1(n_var,n_ens)
  real(8)             :: work2(n_var,n_ens)
  real(8),parameter   :: pi = 3.141592653589d0
!
  do j=1,n_ens
    call random_number(work1(1:n_var,j))  ! Uniform random number between 0 and 1
    call random_number(work2(1:n_var,j))
  enddo
!
! Box-Muller's method
  do j=1,n_ens
  do i=1,n_var
    work1(i,j)= dsqrt(-2.d0*dlog(work1(i,j)))*dcos(2.d0*pi*work2(i,j))
  enddo
  enddo
!
end subroutine random3
end module m_random3


Program gas
IMPLICIT none
Real ::  random, y, c, vi, vf, k(2), h, fk
Integer ::  i, n, T
Real, parameter :: R=8.314 !Costante dei gas

n=15 !moli
T=273.15 !Temperatura
vi=50 !Volume iniziale
vf=200 !Volume finale
c=0    !Centri
call Random_seed !Randomize

Do i=1,1000000
call random_number(random)
k(1)=random*ABS(vf-vi)+vi !assegna la x di k

call random_number(random)

SELECT CASE(f(vf)>f(vi)) !assegna la y di k al massimo superiore a 5 dal punto più alto
CASE (.true.)
 fk=random*(f(vf)+5)
 h=f(vf)+5
CASE (.false.)
 fk=random*(f(vi)+5)
 h=f(vi)+5
CASE default
fk=50
END SELECT

k(2)=fk !Assegna la y del punto

y=f(k(1))

IF (k(2)<y) c=c+1 !Verifica se il punto è sotto la funzione

END DO

WRITE(*,fmt='(F20.4,A1,F20.4)') (c/i)*ABS(vf-vi)*h, " ", n*R*T*log(vf/vi)

STOP

CONTAINS

REAL FUNCTION f(x) !Trova la f(x)
REAL :: x
f=(n*R*T)/x
END FUNCTION f
END PROGRAM gas


subroutine apply_linearized_pde_operator(t, q, p, output)

! For the PDE q_t = g(q), calculates g'[q](p), i.e. the linearization
! of g, about q, applied to perturbation p
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: Base function of the linearization.
!   p: Perturbation to which the linearized operator is applied.
!   output: g'[q](p), calculated here.

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(in) :: q, p
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(out) :: output

    integer :: ix, iy

    !$omp parallel do private(ix)
    do iy = 1, my
        do ix = 1, mx
            output(ix, iy, 1) =  &
                (p(ix+1, iy, 1) - 2*p(ix, iy, 1) + p(ix-1, iy, 1)) / dx**2 +  &
                (p(ix, iy+1, 1) - 2*p(ix, iy, 1) + p(ix, iy-1, 1)) / dy**2
        end do
    end do

end subroutine apply_linearized_pde_operator


module integrate_module

    implicit none
    private
    public              :: integral

contains

    function integral(f, a, b, n) result (integral_result)
        ! Calculates a trapezoidal approximation to an area using n trapezoids
        ! The region is bounded by lines x=a, y=0, x=b, and the curve y=f(x)

        interface
            function f(x) result (f_result)
                real, intent(in)    :: x
                real                :: f_result
            end function f
        end interface

        real, intent(in)            :: a, b
        integer, intent(in)         :: n
        real                        :: integral_result
        real                        :: h, total
        integer                     :: i

        h = (b - a) / n

        ! Calculate the sum f(a)/2+f(a+h)+...+f(b-h)+f(b)/2
        ! Do the first and last terms first
        total = 0.5 * (f(a) + f(b))
        do i = 1, n - 1
            total = total + f(a + i * h)
        end do

        integral_result = h * total
    end function integral

end module integrate_module

module function_module
    implicit none
    private
    public                      :: square

contains
    function square(x) result (squared_x)

        real, intent(in)        :: x
        real                    :: squared_x

        squared_x = x ** 2

    end function square

end module function_module

program integrate

    use integrate_module
    use function_module

    implicit none

    print *, integral(square, a=0.0, b=1.0, n=100)

end program integrate


module utils
    implicit none

    private
    public get_sigma_thicknesses
    public get_vertical_interpolation_weights
    public get_flux_conv_uvq

contains
    function get_half_sigma(sig) result(sigh)
        real, intent(in) :: sig(:)

        real :: sigh(size(sig)+1)

        integer :: k

        sigh(1) = 0.0
        do k = 2, size(sig)+1
            sigh(k) = 2*sig(k-1) - sigh(k-1)
        end do
    end function get_half_sigma

    function get_sigma_thicknesses(sig) result(dsig)
        real, intent(in) :: sig(:)

        real :: dsig(size(sig))

        real :: hsg(size(sig)+1)

        integer :: k

        hsg = get_half_sigma(sig)

        do k = 1, size(sig)
            dsig(k) = hsg(k+1) - hsg(k)
        end do
    end function get_sigma_thicknesses

    function get_flux_conv_uvq(sig) result(grdsig)
        use physical_constants, only: grav, p0

        real, intent(in) :: sig(:)

        real :: dsig(size(sig))

        real :: grdsig(size(sig))

        dsig = get_sigma_thicknesses(sig)

        grdsig = grav/(dsig*p0)
    end function get_flux_conv_uvq

    function get_vertical_interpolation_weights(sig) result(wvi)
        use physical_constants, only: grav, cp, p0

        real, intent(in) :: sig(:)

        real :: wvi(size(sig),2)

        integer :: k, nlev
        real :: sigh(size(sig)+1), sigl(size(sig))

        nlev = size(sig)

        ! 1.2 Functions of sigma and latitude
        sigh = get_half_sigma(sig)
        sigl = log(sig)

!        do k = 1, nlev
!            sigl(k) = log(fsg(k))
!            grdsig(k) = grav/(dhs(k)*p0)
!            grdscp(k) = grdsig(k)/cp
!        end do

        ! Weights for vertical interpolation at half-levels(1,nlev) and surface
        ! Note that for phys.par. half-lev(k) is between full-lev k and k+1
        ! Fhalf(k) = Ffull(k)+WVI(K,2)*(Ffull(k+1)-Ffull(k))
        ! Fsurf = Ffull(nlev)+WVI(nlev,2)*(Ffull(nlev)-Ffull(nlev-1))
        do k = 1, nlev-1
            wvi(k,1) = 1.0/(sigl(k+1) - sigl(k))
            wvi(k,2) = (log(sigh(k+1)) - sigl(k))*wvi(k,1)
        end do

        wvi(nlev,1) = 0.0
        wvi(nlev,2) = (log(0.99) - sigl(nlev))*wvi(nlev-1,1)
    end function get_vertical_interpolation_weights
end module utils


subroutine calc_typeI_migration(iplanet, tmig1)
  !
  ! Computes the Type I migration timescale of a given planet
  !

  use planetdata
  use gravdata, only: mstar, omegaK,cs,sigma
  use unitdata, only: pi,yr

  implicit none

  integer, intent(in) :: iplanet
  real, intent(inout) :: tmig1
  real :: hp, aspectratio,mdiscmig

  hp = cs(iplanetrad(iplanet))/omegaK(iplanetrad(iplanet))
  aspectratio = hp/ap(iplanet)

  mdiscmig = pi*ap(iplanet)*ap(iplanet)*sigma(iplanetrad(iplanet))

  ! Baruteau et al (2013) expression
  tmig1 = mstar*mstar*aspectratio*aspectratio/(mdiscmig*mp(iplanet)*omegaK(iplanetrad(iplanet)))

  ! Old Bate et al expression
  !tmig1 = aspectratio*mstar/(mp(iplanet)*omegaK(iplanetrad(iplanet)))

end subroutine calc_typeI_migration


      double precision function determ(array,nord,nrows)
c
c     calculate determinate of a square matrix
c        (from bevington "data reduction and error analysis
c         for the physical sciences" pg 294)
c     array: matrix to be analyzed
c     nord: order of matrix
c     nrows:  first dimension of matrix in calling routine
c
      double precision array(nrows,nrows)
      determ = 1.
      do 150 k=1,nord
c
c
        if (array(k,k).ne.0) go to 130
        do 100 j=k,nord
          if (array(k,j).ne.0) go to 110
  100   continue
        determ = 0.
        go to 160
c
  110   do 120 i=k,nord
          saved = array(i,j)
          array(i,j) = array(i,k)
  120   array(i,k) = saved
        determ = -determ
c
  130   determ = determ*array(k,k)
        if (k.ge.nord) go to 150
        k1 = k+1
        do 140 i=k1,nord
          do 140 j=k1,nord
  140   array(i,j) = array(i,j)-array(i,k)*array(k,j)/array(k,k)
  150 continue
  160 return
c end double precision function determ
      end


function distance(i) result(j)
    REAL, intent(in) :: i ! input
    integer :: j ! output

    INTEGER :: num
    INTEGER :: offset

    num = FLOOR(REAL(CEILING(SQRT(i))) / 2)
    offset = MOD(INT(i - ((2 * num - 1) ** 2)), 2 * num)

    j = num + ABS(offset - num)
 end function distance

 program one
    integer :: distance
    REAL :: n = 23
    print *, "distance of ", n, " is: ", distance(n)
 end program one


program Mean

  real :: a(10) = (/ (i, i=1,10) /)
  real :: amean, gmean, hmean

  amean = sum(a) / size(a)
  gmean = product(a)**(1.0/size(a))
  hmean = size(a) / sum(1.0/a)

  if ((amean < gmean) .or. (gmean < hmean)) then
    print*, "Error!"
  else
    print*, amean, gmean, hmean
  end if

end program Mean


! ----------------------------------------------------------------------
! MODULE: m_get_lambda
! ----------------------------------------------------------------------
! Purpose:
!   calculate lambda values from radian values
! ----------------------------------------------------------------------
! Author :	John Donovan, Geoscience Australia
! Created:	26 March 2020
! ----------------------------------------------------------------------

        MODULE m_get_lambda
      IMPLICIT NONE

        CONTAINS

        SUBROUTINE get_lambda(rs, rp, sep, lambda, idbprt, idebug )

!     Calculate lambda

!      rs  : apparent radius of sun as viewed from satellite (radians)
!      rp  : apparent radius of eclipsing body as viewed from satellite (radians)
!      sep : apparent separation of the center of the Sun and eclipsing body (radians)

!      lambda : fraction of Sun's disk visible (1.0 = no eclipse; 0, = total eclipse)

        IMPLICIT NONE
        INTEGER (KIND = 4) :: idbprt,idebug
        REAL (KIND = 8)    :: rs,rp,sep,lambda
        REAL (KIND = 8)    :: r1,r2,phi,hgt,thet
        REAL (KIND = 8)    :: area1,area2,area3,ari,pi

!     function

        pi =  3.14159265359d0

        if (rs+rp.le.sep) then
!       no eclipse
        return
        elseif( rp-rs.ge.sep ) then
!       full eclipse
        lambda = 0.d0
        return
        else
!       partial eclipse, do the calculations

        if(sep.le.rs-rp)go to 361
!       set r1 = smaller disc, r2 = larger
        if(rs.gt.rp)go to 371
        r1=rs
        r2=rp
        go to 370
  371   continue
        r1=rp
        r2=rs
  370   continue
!         phi = 1/2 angle subtended in disc 1 by arc of intersection
        phi = dacos((r1*r1+sep*sep-r2*r2)/(2.0d0*r1*sep))
        if (phi.lt.0.d0) phi = pi + phi
        if(r2/r1.gt.5.0d0)go to 365
!        thet = 1/2 angle subtended in disc 2 by arc of intersection
!        hgt  = 1/2 linear distance between ends of arc of intersection
        hgt=r1*dsin(phi)
        thet=dasin(hgt/r2)
        area2=sep*hgt
        area3=thet*r2**2
        go to 366
  365   continue
!         one disc much bigger - treat boundary as a straight line
        hgt=dsqrt(r1**2-(sep-r2)**2)
        area2=hgt*(sep-r2)
        area3=0.0d0
  366 continue
        area1=(pi-phi)*r1**2
!         ari = area of non-overlapped portion of small disc
        ari=area1+area2-area3
        area1=pi*rs**2
        if(rs.gt.rp)go to 362
!         sun is small disc
        lambda=ari/area1
        go to 999
  362   continue
!         eclipsing body is small disc
        area2=pi*rp**2
        lambda=(area1+ari-area2)/area1
        go to 999
  361  continue
!         eclipsing body lies within sun's disc - what fraction of sun's disk is blocked
        lambda=(rs**2-rp**2)/rs**2

      endif

  999 continue

      return
      END SUBROUTINE

      END MODULE


!PROGRAM expint
MODULE expint

  IMPLICIT none

!!$  do i = 1,1000
!!$     write(55,*)0.01*REAL(i),Ei(0.01*REAL(i))
!!$  end do

  integer, parameter   :: Nei = 10000
  real, parameter      :: Ei_xmax = 20.
  real                 :: Ei_dx
  real, dimension(Nei) :: Ei_tab,Ei_x

CONTAINS

  SUBROUTINE initEi

    real    :: x
    integer :: i

    Ei_dx = Ei_xmax/REAL(Nei)
    do i = 1,Nei
       Ei_x(i) = Ei_dx*REAL(i)
       Ei_tab(i) = Ei_ex( Ei_x(i) )
    end do

  END SUBROUTINE initEi

  SUBROUTINE testEi

    real    :: x
    integer :: i

    do i = 1,5*Nei
       x = REAL(i)*Ei_dx/5.
       write(88,*)x,Ei(x),Ei_ex(x)
    end do

  END SUBROUTINE testEi

  FUNCTION Ei(x) RESULT(y)
    real  :: x,y

    integer :: j

    j = MIN(INT(x/Ei_dx),Nei-1)
!    print *,x,j,Ei_dx,Ei_x(Nei)
    y = Ei_tab(j) + (Ei_tab(j+1)-Ei_tab(j))*(x-Ei_x(j))/Ei_dx
!    write(55,*) x

  END FUNCTION Ei

  FUNCTION Ei_ex(x) RESULT (y)
    real  :: x,y

    real, parameter :: a0 = -0.57721566
    real, parameter :: a1 =  0.99999193
    real, parameter :: a2 = -0.24991055
    real, parameter :: a3 =  0.05519968
    real, parameter :: a4 = -0.00976004
    real, parameter :: a5 =  0.00107857

    real, parameter :: AA1 = 2.334733
    real, parameter :: AA2 = 0.250621
    real, parameter :: BB1 = 3.330657
    real, parameter :: BB2 = 1.681534

    if (x.le.1) then
       y = a0+x*(a1+x*(a2+x*(a3+x*(a4+x*a5)))) - LOG(x)
    else
       y = (AA2+x*(AA1+x))/(BB2+x*(BB1+x))/(x*EXP(x))
    end if

  END FUNCTION Ei_ex

!END PROGRAM expint
END MODULE expint


	FUNCTION PR_HGNM  ( hgtn )
C************************************************************************
C* PR_HGNM								*
C*									*
C* This function computes a distance in meters, given a distance in     *
C* nautical miles.  The following equation is used:                     *
C*									*
C*                HGTM  =  1852. * HGTN	                 		*
C*									*
C* REAL PR_HGNM  ( HGTN )						*
C*									*
C* Input parameters:							*
C*	HGTN		REAL		Distance in nautical miles      *
C*									*
C* Output parameters:							*
C*	PR_HGNM		REAL		Distance in meters              *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	11/99	                      			*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for invalid data.
C
	IF  ( ERMISS ( hgtn ) )  THEN
	    PR_HGNM = RMISSD
	  ELSE
C
C*	    Do the conversion.
C
	    PR_HGNM = 1852. * hgtn
	END IF
C*
	RETURN
	END


! derivative_near_singular.f90 --
!
!     Example belonging to "Modern Fortran in Practice" by Arjen Markus
!
!     This work is licensed under the Creative Commons Attribution 3.0 Unported License.
!     To view a copy of this license, visit http://creativecommons.org/licenses/by/3.0/
!     or send a letter to:
!     Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA.
!
!     Simple program to determine the performance differences between
!     using array-valued functions and ordinary do-loops
!
!     Determine (automatically and manually) the derivative near a
!     mildly singular point
!
program derivative_near_singular

    use automatic_differentiation

    implicit none

    type(autoderiv) :: x
    type(autoderiv) :: result
    real(kind=wp)   :: approx
    integer         :: i

    real(kind=wp), dimension(10) :: value = &
        (/ 0.001, 0.0005, 0.0002, 0.0001, 0.00005, 0.00002, 0.00001, &
           0.000005, 0.000002, 0.000001 /)

    do i = 1,size(value)
        x%v  = 1.0_wp + value(i)
        x%dv = 1.0_wp

        result = f(x)
        approx = fprime(x%v)

        write(*,'(10f12.8)') x%v, result%v, result%dv, approx, &
            result%dv+0.5_wp+2.0*(x%v-1.0_wp)/3.0_wp, &
            approx   +0.5_wp+2.0*(x%v-1.0_wp)/3.0_wp
    enddo

contains

function f( x )
    type(autoderiv), intent(in) :: x
    type(autoderiv)             :: f

    f = log(x) / (x-1.0_wp)
end function f

real(kind=wp) function fprime( x )
    real(kind=wp) :: x

    real(kind=wp) :: eps

    eps    = x - 1.0_wp
    fprime = (-0.5_wp + eps / 6.0_wp - eps**2 / 12.0_wp + eps**3 / 20.0_wp) / x
end function fprime

end program derivative_near_singular


module numerical_integration
        implicit none
        ! Contains procedures for numerical integration
        ! From Numerical Recipes in FORTRAN

contains
        function simpson(x,y,n)
                implicit none
                integer, parameter :: dp = selected_real_kind(14)
                integer, intent(in) :: n
                integer :: i
                real(kind=dp) :: simpson
                real(kind=dp), dimension(n), intent(in) :: x, y
                real(kind=dp) :: sum, h

                sum = 0.0d0
                h = dabs(x(n) - x(1))/dfloat(n-1)
                do i=1, n/2 ! Since n is odd, n/2 is the same as (n-1)/2
                        sum = sum + y(2*i-1) + 4.0d0*y(2*i) + y(2*i+1)
                end do
                simpson = sum*h/3.0d0
        end function simpson

        subroutine rk4(
end module numerical_integration


PROGRAM GF2D_HFR
 USE MATLIB
 USE FDLIB
 USE GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !Variable statements
 !-----------------------------------------------------------
 !Constant values / parameters
 REAL(DP), PARAMETER :: c0 = 343, PI = 3.14159
 COMPLEX(DP), PARAMETER :: j = (0,1)
 !Inputs
 REAL(DP) :: L, H, f, zs, As
 !Propagation domain discretization
 INTEGER :: N, Ns, Na, M, nz, mx, nn
 REAL(DP) :: k0, lmbda0, Ha, dz, dr, dkz
 REAL(DP), ALLOCATABLE, DIMENSION(:) :: r, z
 COMPLEX(DP) :: beta
 !Atmosphere variables
 COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: k, dk2, kz, Phase, Ref, DELTA
 !Terrain coordinate transform
 REAL(DP) :: H0, x0, s, xl, xr
 REAL(DP), ALLOCATABLE, DIMENSION(:) :: alti, linear, alpha, dalpha
 !z-domain Pressure field
 COMPLEX(DP), ALLOCATABLE, DIMENSION(:,:) :: P, PHI, PHI1, PHI2, Preal, Pimag
 COMPLEX(DP) :: A0, A2, B
 REAL(DP) :: Ps
 !kz-domain Pressure field
 REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: WA, LP, LPrms, P0
 REAL(DP), ALLOCATABLE, DIMENSION(:) :: CH, LPg, LPrmsg
 !FFT Work array
 COMPLEX(DP), ALLOCATABLE, DIMENSION(:,:) :: FPHI, FPHIi, FPHIr
 COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: BUFR, FPHIs
 INTEGER, DIMENSION(100) :: IFAC
 !CPU Time
 REAL :: start, finish
 !-----------------------------------------------------------
 !User interface
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "GF2D_HFR"
 WRITE(*,*) "Dimension 	: 	2D"
 WRITE(*,*) "Atmosphere	:	Homogeneous"
 WRITE(*,*) "Boundary 	:	Flat"
 WRITE(*,*) "Impedance	:	Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Enter inputs L, H, f, zs, As"
 WRITE(*,*) ""
 READ *, L, H, f, zs, As
 !----------------------------------------------------------
 !Problem parameters
 !-----------------------------------------------------------
 lmbda0 = c0/f
 k0 = 2*PI*f/c0
 dz = lmbda0/10
 dr = lmbda0/10
 Ha = 30*lmbda0
 N = floor(H/dz)
 M = floor(L/dr)
 Ns = MAX(1,floor(zs/dz))
 Na = floor(Ha/dz)
 !-----------------------------------------------------------
 !Memory allocation
 !-----------------------------------------------------------
 ALLOCATE(k(N), kz(N), Ref(N), Phase(N), dk2(N), z(N), DELTA(N), r(M), &
 BUFR(N), PHI(N,M+1), FPHI(N,M), FPHIi(N,M), FPHIr(N,M), FPHIs(M), &
 WA(2,N), CH(2*N), PHI1(N,M), PHI2(N,M), P(N,M), LP(N,M), LPrms(N,M), &
 P0(N,M), LPg(M), LPrmsg(M))
 !-----------------------------------------------------------
 !Discretization
 !-----------------------------------------------------------
 !z-direction wavenumber and kz-domain discretization
 z = (/ (nz*dz, nz = 1,N) /)
 dkz = 2*PI/(N*dz)
 DO nz = 1,N
  IF (nz >= N-Na) THEN
   k(nz) = k0+As*j*(nz-N+Na)**2/Na**2
  ELSE
   k(nz) = k0
  ENDIF
  kz(nz) = nz*dkz
  dk2(nz) = j*(k(nz)**2-(k0**2))/(2*k0)
  Phase(nz) = EXP(j*dr*(SQRT(k0**2-kz(nz)**2)-k0**2))
 END DO
 DELTA = EXP(j*dr*dk2/(2*k0))
 !-----------------------------------------------------------
 ALLOCATE(dalpha(1:M),r(0:M+1),linear(0:M+1),alpha(1:M+1))
 r = (/ (mx*dr, mx = 0,M+1) /)
 linear(0) = 0
 DO mx = 1,M+1
   xl = HILL(H0,x0,r(mx-1),s)
   xr = HILL(H0,x0,r(mx),s)
   alpha(mx) = (xr - xl)/dr
   linear(mx) = linear(mx-1) + (1 + alpha(mx))*dr
 END DO
 !-----------------------------------------------------------
 !Starting field
 !-----------------------------------------------------------
 A0 = 1.3717
 A2 = -0.3701
 B = 3
 DO nz = 1,N
  PHI(nz,1) = SQRT(j*k0)* &
  ((A0+A2*k0**2*(nz*dz-zs)**2)*EXP(-k0**2*(nz*dz-zs)**2/B) &
  + (A0+A2*k0**2*(nz*dz+zs)**2)*EXP(-k0**2*(nz*dz+zs)**2/B))
 END DO
 !-----------------------------------------------------------
 !Main Loop
 !-----------------------------------------------------------
 !Start of Forward-marching procedure
 CALL CPU_TIME(START)
 !Initialization of the FFT subroutines :
 !IFAC and WA depend only on N -> used in CFFTF1 and CFFTB1
 CALL CFFTI1(N,WA,IFAC)
 DO mx = 2,M+1
  WRITE(*, *) "Step :", mx-1, "out of", M
  !Surface term
  dalpha(mx-1) = (alpha(mx)-alpha(mx-1))/dr
  DO nz = 1,N
   FPHIs(mx-1) = FPHIs(mx-1)+PHI(nz,mx-1)*dz*EXP(-j*beta*nz*dz)
  END DO
  BUFR = PHI(:,mx-1)
  CALL CFFTF1(N,BUFR,CH,WA,IFAC)
  FPHIi(:,mx-1) = BUFR
  CALL FLIP(BUFR)
  FPHIr(:,mx-1) = BUFR
  FPHI(:,mx-1) = (FPHIi(:,mx-1)+FPHIr(:,mx-1))*Phase
  BUFR = FPHI(:,mx-1)
  CALL CFFTB1(N,BUFR,CH,WA,IFAC)
  PHI1(:,mx-1) = BUFR
  PHI2(:,mx-1) = 2*j*beta*FPHIs(mx-1)*EXP(-j*beta*z)*EXP(j*dr*(SQRT(k0**2-beta**2)-k0**2))
  PHI(:,mx) = DELTA*(PHI1(:,mx-1)+PHI2(:,mx-1))*EXP(j*k0*z*dalpha(mx-1))
  P(:,mx-1) = EXP(j*k0*(mx-1)*dr)*PHI(:,mx)*(1/SQRT((mx-1)*dr))
 END DO
 !End of Forward-marching procedure
 CALL CPU_TIME(FINISH)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 Ps = ABS(P(Ns,1))
 Preal = REAL(REAL(P))
 Pimag = REAL(AIMAG(P))
 DO mx = 1,M
  DO nz = 1,N
   LP(nz,mx) = 20*LOG10(ABS(P(nz,mx-1))/Ps)
  END DO
 END DO
 LPg = LP(1,1:M)
 LPrms = LP/SQRT(2.)
 LPrmsg = LPrms(1,1:M)
 !-----------------------------------------------------------
 !Output
 !-----------------------------------------------------------
 OPEN(UNIT=10,FILE="GF2D_HFR_LPg.dat")
 OPEN(UNIT=20,FILE="GF2D_HFR_LP.dat")
 OPEN(UNIT=30,FILE="GF2D_HFR_P.dat")
 DO nz = 1,N
   WRITE(20, 100, advance="no") LP(nz,1:M)
   WRITE(30, 101, advance="no") P(nz,1:M)
 END DO
 DO mx = 1,M
  WRITE(10, 100) mx*dr, LPg(mx), LPrmsg(mx)
 END DO
 100 FORMAT(3X,F8.3,$)
 101 FORMAT(3X,F8.3,SP,F8.3,SS,"i",$)
 PRINT *, "Main CPU time (s) :", FINISH-START
 PRINT *, "Source pressure P0 (dB) :", 20*LOG10(Ps)
 !-----------------------------------------------------------
END PROGRAM GF2D_HFR


module vectores
    implicit none
    contains

    ! Producto escalar entre dos vectores u, v de longitud n
    function producto_escalar(n, u, v) result(p)
        integer, intent(in) :: n
        double precision, intent(in) :: u(n), v(n)
        double precision :: p
        p = dot_product(u, v)
    end function

    ! Producto vectorial entre dos vectores u, v de longitud 3
    function producto_vectorial(u, v) result(w)
        double precision, intent(in) :: u(3), v(3)
        double precision :: w(3)
        w(1) = u(2) * v(3) - u(3) * v(2)
        w(2) = u(3) * v(1) - u(1) * v(3)
        w(3) = u(1) * v(2) - u(2) * v(1)
    end function
end module


program circle
implicit none
integer, parameter :: num_pts = 100
integer :: i
real, parameter :: pi = 4.0*atan(1.0)
real :: x,y, theta

do i=1, num_pts
        x = cos(i*2*pi/num_pts)
        y = sin(i*2*pi/num_pts)
        write(*,*) x, y, atan2(y,x)

end do
end program circle


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     Purpose:
!
!     To illustrate the usage of poistg to solve the equation
!
!     (1/cos(x))(d/dx)(cos(x)(du/dx)) + (d/dy)(du/dy) =
!
!           2 * y**2 * (6-y**2) * sin(x)
!
!     on the rectangle -pi/2 < x < pi/2 and 0 < y <  1
!
!     with the boundary conditions
!
!     (du/dx) (-pi/2, y) = (du/dx)(pi/2, y) = 0 , 0 <= y <= 1  (2)
!
!     u(x, 0) = 0                                           (3)
!                                 -pi/2 <= x <= pi/2
!     (du/dy)(x, 1) = 4sin(x)                               (4)
!
!     using finite differences on a staggered grid with
!     deltax (= dx) = pi/40 and deltay (= dy) = 1/20 .
!        to set up the finite difference equations we define
!     the grid points
!
!     x(i) = -pi/2 + (i-0.5)dx            i=1, 2, ..., 40
!
!     y(j) = (j-0.5)dy                    j=1, 2, ..., 20
!
!     and let v(i, j) be an approximation to u(x(i), y(j)).
!     numbering the grid points in this fashion gives the set
!     of unknowns as v(i, j) for i=1, 2, ..., 40 and j=1, 2, ..., 20.
!     hence, in the program m = 40 and n = 20.  at the interior
!     grid point (x(i), y(j)), we replace all derivatives in
!     equation (1) by second order central finite differences,
!     multiply by dy**2, and collect coefficients of v(i, j) to
!     get the finite difference equation
!
!     a(i)v(i-1, j) + b(i)v(i, j) + c(i)v(i+1, j)
!
!     + v(i, j-1) - 2v(i, j) + v(i, j+1) = f(i, j)            (5)
!
!     where s = (dy/dx)**2, and for i=2, 3, ..., 39
!
!     a(i) = s * cos(x(i)-dx/2)
!
!     b(i) = -s * (cos(x(i)-dx/2)+cos(x(i)+dx/2))
!
!     c(i) = s * cos(x(i)+dx/2)
!
!     f(i, j) = 2dy**2 * y(j)**2 * (6-y(j)**2) * sin(x(i)) , j=1, 2, ..., 19.
!
!        to obtain equations for i = 1, we replace equation (2)
!     by the second order approximation
!
!     (v(1, j)-v(0, j))/dx = 0
!
!     and use this equation to eliminate v(0, j) in equation (5)
!     to arrive at the equation
!
!     b(1)v(1, j) + c(1)v(2, j) + v(1, j-1) - 2v(1, j) + v(1, j+1)
!
!                       = f(1, j)
!
!     where
!
!     b(1) = -s * (cos(x(1)-dx/2)+cos(x(1)+dx/2))
!
!     c(1) = -b(1)
!
!     for completeness, we set a(1) = 0.
!        to obtain equations for i = 40, we replace the derivative
!     in equation (2) at x=pi/2 in a similar fashion, use this
!     equation to eliminate the virtual unknown v(41, j) in equation
!     (5) and arrive at the equation
!
!     a(40)v(39, j) + b(40)v(40, j)
!
!     + v(40, j-1) - 2v(40, j) + v(40, j+1) = f(40, j)
!
!     where
!
!     a(40) = -b(40) = -s * (cos(x(40)-dx/2)+cos(x(40)+dx/2))
!
!     for completeness, we set c(40) = 0.  hence, in the
!     program nperod = 1.
!
!     For j = 1, we replace equation (3) by the second order
!     approximation
!
!                (v(i, 0) + v(i, 1))/2 = 0
!
!     to arrive at the condition
!
!                v(i, 0) = -v(i, 1) .
!
!     For j = 20, we replace equation (4) by the second order
!     approximation
!
!                (v(i, 21) - v(i, 20))/dy = 4 * sin(x)
!
!     and combine this equation with equation (5) to arrive at
!     the equation
!
!     a(i)v(i-1, 20) + b(i)v(i, 20) + c(i)v(i+1, 20)
!
!     + v(i, 19) - 2v(i, 20) + v(i, 21) = f(i, 20)
!
!     where
!
!     v(i, 21) = v(i, 20)  and
!
!     f(i, 20) = 2 * dy**2 * y(j)**2 * (6-y(j)**2) * sin(x(i)) - 4 * dy * sin(x(i))
!
!     hence, in the program nperod = 2.
!
!     The exact solution to this problem is
!
!     u(x, y) = y**4 * cos(x) .
!
!     From dimension statement we get that size(f, dim=1) = 42
!
program test_poistg

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter        :: M = 40, N = 20
    integer(ip), parameter        :: IDIMF = M + 2
    integer(ip)                   :: mperod, nperod, i, j, ierror
    real(wp), dimension(IDIMF, N) :: f
    real(wp), dimension(M)        :: a, b, c, x
    real(wp)                      :: y(N), dx, dy
    real(wp), parameter           :: ZERO = 0.0_wp, HALF = 0.5_wp
    real(wp), parameter           :: ONE = 1.0_wp, TWO = 2.0_wp

    ! Set boundary conditions
    mperod = 1
    nperod = 2

    ! Set mesh sizes
    dx = PI/M
    dy = ONE/N

    ! Generate and store grid points for computation
    do i = 1, M
        x(i) = -HALF_PI + (real(i, kind=wp) - HALF)*dx
    end do

    do j = 1, N
        y(j) = (real(j, kind=wp) - HALF)*dy
    end do

    ! Generate coefficients
    block
        real(wp) :: s, half_dx

        s = (dy/dx)**2
        half_dx = dx/TWO
        a(1) = ZERO
        b(1) = -s * cos(-HALF_PI + dx)/cos(x(1))
        c(1) = -b(1)

        do i = 2, M
            a(i) = s * cos(x(i)-half_dx)/cos(x(i))
            c(i) = s * cos(x(i)+half_dx)/cos(x(i))
            b(i) = -(a(i) + c(i))
        end do

        a(M) = -b(M)
        c(M) = ZERO
    end block

    ! Generate right hand side of equation
    block
        real(wp), parameter :: FOUR = 4.0_wp
        real(wp), parameter :: SIX = 6.0_wp

        do j = 1, N
            do i = 1, M
                f(i, j) = TWO * (dy**2) * (y(j)**2) * (SIX - y(j)**2) * sin(x(i))
            end do
        end do
        f(1:M,N) = f(1:M,N) - FOUR * dy * sin(x)
    end block

    ! Solve 2D real linear system on staggered grid
    call poistg(nperod, N, mperod, M, a, b, c, IDIMF, f, ierror)

    ! Compute discretization error. The exact solution is
    !
    !  u(x,y) = (y**4) * sin(x)
    !
    block
        real(wp), parameter :: KNOWN_ERROR = 0.564170618941665e-003
        real(wp) :: discretization_error
        real(wp) :: exact_solution(M,N)

        do j = 1, N
            do i = 1, M
                exact_solution(i,j) = (y(j)**4) * sin(x(i))
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:M,:N)))

        call check_output('poistg', ierror, KNOWN_ERROR, discretization_error)
    end block

end program test_poistg


      function func(x)
        func= x*exp(x)
      end

      program  aa

!      subroutine prder(x,func,n,h,D)
      !primera derivada de orden n en el error, en el intervalo h

      implicit none
      external func
      real::h,func,x
      REAL,ALLOCATABLE,DIMENSION(:,:)::D
      integer::i,j,n
       x=2
       n=4
       h=0.004
      allocate(D(n,n))
      D(:,:)=0.0d1
      !CADA fila es un D(fila ejemplo 1) con la primer cordenada 2H la segunda H la tercera H/2. la segunda fila es un D2 con primer elemento H segundo H/2 Y ASI

      do j=0,n-1
      do i=1,n-j

      if (j==0) then
      if (i==1) then
      D(j+1,i)=((func(x+2*h)-func(x-2*h))/(2*2*h))
      else
      D(j+1,i)=((func(x+2*(h/(2*(i-1))))-func(x-2*(h/(2*(i-1)))))/(2*2*(h/(2*(i-1)))))
      end if
      else
      D(j+1,i)=(((2**(2*(j))))*D(j,i+1)-D(j,i))/((2**(2*(j)))-1)

      end if
      end do

      end do

      print*, D(n,1)

      print*, (exp(2.)*3)
      return
      end

!     REAL FUNCTION AVRAGE()
!     REAL X,Y,Z,SUM
!     SUM = X + Y + Z
!     AVRAGE = SUM /3.0
!     RETURN
!     END


! This is a subroutine that finds y from A.y = F for
! banded NON-symmetric matrices. From Thompson text
!
! INPUTS:
!        A  = non-symmetric banded matrix
!        F  = vector from A.Y = F
!        IB = bandwidth of matrix (columns)
!        neq= number of rows in the matrix
!
! OUTPUTS:
!        Y  = solution vector from A.Y = F
!----------------------------------------------------------
SUBROUTINE nsymgauss(Y,A,F,neq,IB)
  IMPLICIT NONE
  INTEGER :: Idiag,i,j,k,Jend,Kbgn,Kend,Ikc,Jkc,Iback,Jc,Kc
  REAL :: FAC
  INTEGER, INTENT(IN) :: neq,IB
  REAL,DIMENSION(neq,IB) :: AA
  REAL,DIMENSION(neq) :: FF
  REAL,DIMENSION(neq,IB),INTENT(IN) :: A
  REAL,DIMENSION(neq),INTENT(IN) :: F
  REAL,DIMENSION(neq),INTENT(OUT) :: Y

! Initialize matrices to overwrite
  DO i = 1,neq
     DO j = 1,IB
        AA(i,j) = A(i,j)
     END DO
     FF(i) = F(i)
  END DO

! Forward elimination
  Idiag = ((IB - 1)/2) + 1
  DO i = 1,neq-1
     Jend = neq
     IF (Jend > (i+Idiag-1)) Jend = i+Idiag-1
     DO j = i+1,Jend
        Kc   = Idiag - (j-i)
        FAC  = -AA(j,Kc)/AA(i,Idiag)
        Kbgn = i
        Kend = Jend
        DO k = Kbgn,Kend
           Ikc = Idiag + (k-i)
           Jkc = Idiag + (k-j)
           AA(j,Jkc) = AA(j,Jkc) + FAC*AA(i,Ikc)
        END DO
        FF(j) = FF(j) + FAC*FF(i)
     END DO
  END DO

! Backward substitution
  Y(neq) = FF(neq)/AA(neq,Idiag)
  DO Iback = 2,neq
     i    = neq - Iback + 1
     Jend = neq
     IF (Jend > (i+(Idiag-1))) Jend = i+(Idiag-1)
     DO j = i+1,Jend
        Jc    = Idiag + (j-i)
        FF(i) = FF(i) - AA(i,Jc)*Y(j)
     END DO
     Y(i) = FF(i)/AA(i,Idiag)
  END DO
END SUBROUTINE nsymgauss


#
# test math operators and order of operations
#

print("Testing math operators and order of operations...")
errors = 0

try assert 1 + 2 * 3 == 7 rescue errors += 1
try assert (1 + 2) * 3 == 9 rescue errors += 1
try assert (1 - 2) * 3 == -3 rescue errors += 1
try assert 1 - 2 * 3 == -5 rescue errors += 1
try assert (3 * 3) ^ 2 == 81 rescue errors += 1
try assert 3 * 3 ^ 2 == 27 rescue errors += 1
try assert 4 * (3 + 3) == 24 rescue errors += 1
try assert 4 / 2 + 6 == 8 rescue errors += 1
try assert 4 / (2 + 6) == 0.5 rescue errors += 1
try assert 60 % 21 // 2 == 9 rescue errors += 1
try assert 63 % (21 // 2) == 3 rescue errors += 1

a = 8
assert (a += 1) == 9
assert (a -= 1) == 8
assert (a /= 2) == 4.0
assert (a //= 2) == 2
assert (a %= 2) == 0

print(if errors "Some tests failed ({errors}) errors\n" else "passed!\n")


! { dg-do run }
! PR fortran/30720
program array_function_1
  integer :: a(5), b, l, u
  l = 4
  u = 2

  a = (/ 1, 2, 3, 4, 5 /)

  b = f(a(l:u) - 2)
  if (b /= 0) call abort

  b = f(a(4:2) - 2)
  if (b /= 0) call abort

  b = f(a(u:l) - 2)
  if (b /= 3) call abort

  b = f(a(2:4) - 2)
  if (b /= 3) call abort

  contains
    integer function f(x)
      integer, dimension(:), intent(in) :: x
      f = sum(x)
    end function
end program


! The MPI library is realized in a way that it takes
! \[
!   t = alpha + beta * sizeof(buf)
! \]
! seconds to send an array `buf` of sizeof(buf) bytes (messages are sent in
! packages).  If you measure the time per a round-trip movement from one process
! to another and back, you can find these two numbers from a simple linear
! regression.
!
! Run with 2 processes only (there are reductions) !
!
! This exercies was suggested by V. Eijkhout
program main
    use mpi_f08
    implicit none
    integer, parameter :: REPS      = 1000
    integer, parameter :: SIZE_MAX  = 100000
    integer, parameter :: SIZE_STEP = 5000
    integer, parameter :: DPK = kind(0.d0)
    integer, parameter :: REAL4_SIZE = storage_size(0.0) / 8

    integer :: n_steps

    integer :: buf_size
    real, allocatable :: buf(:)   ! Buffer to send-receive
    real, allocatable :: s_arr(:) ! Size of message
    real, allocatable :: t_arr(:) ! Time per message
    real :: alpha, beta, rho

    real(kind=DPK) :: start_time, end_time, time_step

    type(MPI_Comm) :: comm
    integer :: n_ranks, my_rank, first_rank, last_rank
    integer :: i, c

    logical :: iam_first_rank, iam_last_rank

    call MPI_Init()
    comm = MPI_COMM_WORLD
    call MPI_Comm_size(comm, n_ranks)
    call MPI_Comm_rank(comm, my_rank)

    first_rank = 0
    last_rank  = n_ranks - 1
    iam_first_rank = (my_rank == first_rank)
    iam_last_rank  = (my_rank == last_rank)

    if (iam_first_rank) then
        n_steps = SIZE_MAX / SIZE_STEP + 1
        allocate(s_arr(n_steps))
        allocate(t_arr(n_steps))
    end if

    buf_size = 0
    c = 1
    do while (buf_size <= SIZE_MAX)
        allocate(buf(buf_size), source=3.14)
        start_time = MPI_Wtime()
        if (iam_first_rank) then
            do i = 1, REPS
                call MPI_Recv(buf, buf_size, MPI_REAL, last_rank, 0, comm, MPI_STATUS_IGNORE)
                call MPI_Send(buf, buf_size, MPI_REAL, last_rank, 0, comm)
            end do
        else if (iam_last_rank) then
            do i = 1, REPS
                call MPI_Send(buf, buf_size, MPI_REAL, first_rank, 0, comm)
                call MPI_Recv(buf, buf_size, MPI_REAL, first_rank, 0, comm, MPI_STATUS_IGNORE)
            end do
        end if
        end_time = MPI_Wtime()
        time_step = (end_time - start_time) / (2.0 * REPS * REAL4_SIZE)
        deallocate(buf)

        if (iam_last_rank) then
            call MPI_Reduce(time_step, time_step, 1, MPI_REAL8, MPI_SUM, first_rank, comm)
        else if (iam_first_rank) then
            call MPI_Reduce(MPI_IN_PLACE, time_step, 1, MPI_REAL8, MPI_SUM, first_rank, comm)
            print '(i8, 1x, es9.2)', buf_size, time_step * 1.d+6 ! mks
            s_arr(c) = real(buf_size)
            t_arr(c) = real(time_step * 1.d+6) ! mks
        end if
        buf_size = buf_size + SIZE_STEP
        c = c + 1
    end do

    if (iam_first_rank) then
        call linear_regression(s_arr, t_arr, alpha, beta, rho)
        print '(2(a, es9.2), a, f0.3)', "alpha=", alpha, " mks, beta=", beta * 1e+3, " ns/byte, r=", rho
        deallocate(s_arr)
        deallocate(t_arr)
    end if

    call MPI_Finalize()

contains

    !---------------------------------------------------------------------------
    ! Does a least-square fit for the model function y(x) = a + b x for the data
    ! provided in arrays x_arr and y_arr of the same size.  The correlation
    ! coefficient is returned in r.
    subroutine linear_regression(x_arr, y_arr, a, b, r)
        implicit none
        real, intent(in)  :: x_arr(:)
        real, intent(in)  :: y_arr(:)
        real, intent(out) :: a
        real, intent(out) :: b
        real, intent(out) :: r
        integer :: n
        real :: sum_x, sum_y, sum_xx, sum_yy, sum_xy, det

        n = size(x_arr)
        if (n /= size(y_arr)) then
            stop "linear_regression: arrays must be of the same size."
        end if
        sum_x  = sum(x_arr)
        sum_y  = sum(y_arr)
        sum_xx = sum(x_arr * x_arr)
        sum_yy = sum(y_arr * y_arr)
        sum_xy = sum(x_arr * y_arr)
        det = n * sum_xx - sum_x**2
        b = (n * sum_xy - sum_x * sum_y) / det
        a = (sum_y - b * sum_x) / n
        r = b * sqrt( det / (n * sum_yy - sum_y**2) )
        return
    end subroutine linear_regression

end program main


subroutine PLegendreA(p,lmax,z, csphase)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function evalutates all of the unnormalized associated legendre
!	polynomials up to degree lmax.
!
!	Calling Parameters:
!		IN
!			lmax:		Maximum spherical harmonic degree to compute.
!			z:		[-1, 1], cos(colatitude) or sin(latitude).
!		OPTIONAL (IN)
!			csphase:	1: Do not include the phase factor of (-1)^m
!					-1: Apply the phase factor of (-1)^m.
!		OUT
!			p:	A vector of all associated Legendgre polynomials evaluated at
!				z up to lmax. The length must by greater or equal to (lmax+1)*(lmax+2)/2.
!	Notes:
!
!	1.	The integral of plm**2 over (-1,1) is 2 * (l+m)! / (2l+1) / (l-m)!.
!	2.	The index of the array p corresponds to l*(l+1)/2 + m + 1.
!	3.	The default is to exlude the Condon-Shortley phase of (-1)^m.
!
!
!	This code is based on the stable recursion relationships in numerical recipes.
!
!	Dependencies:	CSPHASE_DEFAULT
!
!	Written by Mark Wieczorek 2003
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	use SHTOOLS, only: CSPHASE_DEFAULT

	implicit none
	integer, intent(in) ::	lmax
	real*8, intent(out) ::	p(:)
       	real*8, intent(in) ::	z
       	integer, intent(in), optional ::	csphase
       	real*8 ::	pm2, pm1, pmm, sinsq, sinsqr, fact, plm, phase
      	integer ::	k, kstart, m, l

	if (size(p) < (lmax+1)*(lmax+2)/2) then
		print*, "Error --- PLegendreA"
     		print*, "P must be dimensioned as (LMAX+1)*(LMAX+2)/2 where LMAX is ", lmax
     		print*, "Input array is dimensioned ", size(p)
     		stop
     	elseif (lmax < 0) then
     		print*, "Error --- PLegendreA"
     		print*, "LMAX must be greater than or equal to 0."
     		print*, "Input value is ", lmax
     		stop
     	elseif(abs(z) > 1.0d0) then
     		print*, "Error --- PLegendreA"
     		print*, "ABS(Z) must be less than or equal to 1."
     		print*, "Input value is ", z
     		stop
     	endif

     	if (present(csphase)) then
     		if (csphase == -1) then
     			phase = -1.0d0
     		elseif (csphase == 1) then
     			phase = 1.0d0
     		else
     			print*, "PLegendreA --- Error"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)."
     			print*, "Input value is ", csphase
     			stop
     		endif
     	else
     		phase = dble(CSPHASE_DEFAULT)
     	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate P(l,0)
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	sinsq = (1.0d0-z)*(1.0d0+z)
	sinsqr = sqrt(sinsq)

      	pm2  = 1.0d0
      	p(1) = 1.0d0

      	if (lmax == 0) return

      	pm1  = z
      	p(2) = pm1

	k = 2

      	do l = 2, lmax, 1
         	k = k+l
         	plm = ( z*dble(2*l-1)*pm1-dble(l-1)*pm2 )/ dble(l)
         	p(k) = plm
         	pm2  = pm1
         	pm1  = plm
      	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate P(m,m), P(m+1,m), and P(l,m)
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      	pmm  = 1.0d0
      	fact = -1.0d0
      	kstart = 1

      	do m = 1, lmax - 1, 1

		! Calculate P(m,m)
        	kstart = kstart+m+1
         	fact = fact+2.0d0
        	pmm = phase * pmm * sinsqr * fact
        	p(kstart) = pmm
        	pm2 = pmm

		! Calculate P(m+1,m)
		k = kstart+m+1
	   	pm1 = z*pmm*dble(2*m+1)
	    	p(k) = pm1

		! Calculate P(l,m)
               	do l = m+2, lmax, 1
               		k = k+l
                  	plm  = ( z*dble(2*l-1)*pm1-dble(l+m-1)*pm2 ) / dble(l-m)
                  	p(k) = plm
                  	pm2  = pm1
                  	pm1  = plm
               	enddo

      	enddo

      	! P(lmax, lmax)
      	kstart    = kstart+m+1
        fact      = fact+2.0d0
        pmm       = phase * pmm * sinsqr * fact
        p(kstart) = pmm

end subroutine PLegendreA


c======================================================================
c                    Module Tensor operations
c=======================================================================
c  This module contains all the operations required to do tensor operations,
c  map into equivalent notations of tensor. print in a sorted way in the
c termianl, and auxiliary functions used in testing of the material routine.
c-----------------------------------------------------------------------
c Version 0.9.2
c Oct 2021
c-----------------------------------------------------------------------
      module tensor_operations
c       INCLUDE 'ABA_PARAM.INC'
        implicit none
      contains

c=======================================================================
c                    subroutine linespace
c=======================================================================
c=======================================================================
c subroutine linespace(ini, end, vector, type): returns  a  1st order
C tensor with even spaced double precision numbers according to the size
c of vector
c-----------------------------------------------------------------------
c Inputs
c   ini: initial value
c   end: end value
c   vector: 1st order tensor with the right size to store the result
c   type: select if incluedes lower end
c       type= 0: not include lower end
c       type= 1: includes lower end
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c=======================================================================
      subroutine linespace (ini, end, vector, type)
        implicit none
        double precision ::ini, end
        double precision, dimension (:) :: vector
        integer :: i, type

        if (type==1) then
          do i=1, (size(vector,1))
            vector(i)=ini+(end-ini)*(i-1)/(size(vector,1)-1)
          end do
        else
          do i=1, (size(vector,1))
            vector(i)=ini+(end-ini)*(i)/(size(vector,1))
          end do
        end if
      end subroutine linespace

c=======================================================================
c                    funcion Trace
c=======================================================================
c=======================================================================
c Returns the trace of a  2nd order tensor
c------------------------------------------------------------------]
c Inputs
c   array: array of size n1xn1
c-----------------------------------------------------------------
c Output
c   tr_A: trace
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c==================================================================
      function Trace(A) result(Tr_A)
        implicit none
        double precision, dimension(:,:):: A
        double precision :: Tr_A
        integer n1
        Tr_A=0.0
        do n1=1,size (A,1)
          Tr_A=Tr_A+A(n1,n1)
        end do
      end function Trace

c=======================================================================
c                    subroutine Ident1
c=======================================================================
c==================================================================
c subroutine Ident1(array,n1): returns a 2nd order identity  tensor
c------------------------------------------------------------------]
c Inputs
c   array: array of size n1xn1
c   n1 :   dimension of the array
c-----------------------------------------------------------------
c Output
c   array: identy tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c==================================================================

      subroutine Ident1(array,n1)
        implicit none
        integer:: i, j     !iterators
        integer:: n1  !dimension square tensor
        double precision :: array(n1,n1)

        do i=1,n1
            do j=1,n1
                array(j,i)=0.0
            end do
        end do

        do i=1,n1
            array(i,i)=1.0
        end do
      end subroutine Ident1

cc======================================================================
cc                    function inv_T_2D
cc=======================================================================
cc==================================================================
cc Returns the inverse of a 2nd order tensor using the LU decomposition.
cc Depends on the LAPACK Fortran package
cc http://www.netlib.org/lapack/explore-html/dd/d9a/group__double_g_ecomputational_ga0019443faea08275ca60a734d0593e60.html
cc------------------------------------------------------------------]
ccInputs
cc    A: Tensor 2D se nxn
cc------------------------------------------------------------------------
ccOutput
cc    A: inverted tensor
c-c-----------------------------------------------------------------------
cc coded by: W. Mora Oct 2021
cc===================================================================
c      function inv_T_2D(A) result(Ainv)
c        external:: DGETRF
c        external:: DGETRI
c        double precision, dimension(:,:), intent(in) :: A
c        double precision, dimension(size(A,1),size(A,2)) :: Ainv
c        double precision, dimension(size(A,1),size(A,2)) :: Ainv_temp
c        double precision, dimension(size(A,1)) :: work  ! work array for LAPACK
c        integer, dimension(size(A,1)) :: ipiv   ! pivot indices
c        integer :: n, info
c
c         ! Store A in Ainv to prevent it from being overwritten by LAPACK
c        Ainv_temp =dble(A)
c        n = size(A,1)
c
c         ! DGETRF computes an LU factorization of a general M-by-N matrix A
c         ! using partial pivoting with row interchanges.
c        call DGETRF(n, n, Ainv_temp, n, ipiv, info)
c        !Error mesage genetrated in the LU decomposition, see the possible
c        !option of values for info in LAPACK documentation
c        if (info /= 0) then
c           stop 'function inv_T_2D- Matrix is numerically singular!'
c        end if
c
c         ! DGETRI computes the inverse of a matrix using the LU factorization
c        call DGETRI(n, Ainv_temp, n, ipiv, work, n, info)
c       !Error mesage genetrated in the LU decomposition, see the possible
c        !option of values for info in LAPACK documentation
c        if (info /= 0) then
c           stop 'Matrix inversion failed!'
c        end if
c
c        Ainv=Ainv_temp
c      end function inv_T_2D

c=======================================================================
c                   subroutine I4dikdjl
cc=======================================================================
cc==================================================================
c Returns the 4th order unit tensor I4ikjl
c-----------------------------------------------------------------------c-----------------------------------------------------------------------
cInputs
c    I4dikdjl_o: 4th order tensor
c-----------------------------------------------------------------------
c coded by: W. Mora Oct 2021
c=====================================================================

      subroutine I4dikdjl(I4dikdjl_o)
        implicit none

         integer:: i, j, k , l     !iterators
         integer:: n1              !matrix dimension
         double precision, dimension(3,3,3,3)::I4dikdjl_o
         double precision, dimension(3,3):: I_3D !Auxiliary 2D order tensors

         n1=3
         call Ident1(I_3D,n1)

         do i=1,n1
             do j=1,n1
                 do k=1,n1
                     do l=1,n1
                      I4dikdjl_o(i,j,k,l)=I_3D(i,k)*
     &                   I _3D(j,l)
                     end do
                 end do
             end do
         end do
      end subroutine I4dikdjl

c=======================================================================
c                   subroutine I4dildjk
c=======================================================================
c=======================================================================
c  Returns the 4th order unit tensor Iiljk
c-----------------------------------------------------------------------
cInputs
c    I4dildjk_o: 4th order tensor
c-----------------------------------------------------------------------
c coded by: W. Mora Oct 2021
c=====================================================================

      subroutine I4dildjk(I4dildjk_o)
        implicit none

         integer:: i, j, k , l     !iterators
         integer:: n1              !matrix dimension
         double precision, dimension(3,3,3,3)::I4dildjk_o
         double precision, dimension(3,3):: I_3D !Auxiliary 2D order tensors

         n1=3
         call Ident1(I_3D,n1)

         do i=1,n1
             do j=1,n1
                 do k=1,n1
                     do l=1,n1
                      I4dildjk_o(i,j,k,l)=I_3D(i,l)*
     &                   I _3D(j,k)
                     end do
                 end do
             end do
         end do
      end subroutine I4dildjk

c======================================================================
c                    Subroutine I4sym
c=======================================================================
c==================================================================
c  Returns the 4th order symmetric identity tensor
c-------------------------------------------------------------------
cInputs
c    I4sym_o: 4th order tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c=====================================================================

      subroutine I4sym(I4sym_o)
       implicit none

        integer:: i, j, k , l     !iterators
        integer:: n1              !matrix dimension
        double precision, dimension(3,3,3,3)::I4sym_o
        double precision, dimension(3,3):: I_3D !Auxiliary 2D order tensors

        n1=3
        call Ident1(I_3D,n1)

        do i=1,n1
            do j=1,n1
                do k=1,n1
                    do l=1,n1
                        I4sym_o(i,j,k,l)=(1.0/2.0)*(I_3D(i,k)*
     &                   I_3D(j,l)+I_3D(i,l)*I_3D(j,k))
                    end do
                end do
            end do
        end do
      end subroutine I4sym

c======================================================================
c                    subroutine P4sym
c=======================================================================
c==================================================================
c  Returns 4th order deviatoric projection tensor
c------------------------------------------------------------------]
cInputs
c    P4sym: 4th order tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c===================================================================
      subroutine P4sym(P4sym_o)

       implicit none
       integer:: i, j, k , l     !iterators
       integer:: n1              !matrix dimension
       double precision, dimension(3,3,3,3)::I4sym_o, P4sym_o !4th order tensors
       double precision, dimension(3,3):: I_3D            !Auxiliary 2D order tensors

       n1=3
       call Ident1(I_3D,n1)

       call I4sym(I4sym_o)

          do i = 1,3
              do j = 1,3
                  do k = 1,3
                      do l = 1,3
                        P4sym_o(i,j,k,l) =0.0
                        P4sym_o(i,j,k,l) =I4sym_o(i,j,k,l)-
     &                     I_3D(i,j)*I_3D(k,l)/3.000000
                      end do
                    end do
                  end do
                end do
      end subroutine P4sym

cc======================================================================
cc                    Subroutine invT4
cc=======================================================================
cc==================================================================
cc  inverts a 4th order tensor
cc------------------------------------------------------------------]
ccInputs
cc    tensor:    4th order tensor to invert
cc    tensor_In: inverted tensor
cc------------------------------------------------------------------------
cc coded by: W. Mora Sep 2021
cc===================================================================
c      subroutine invT4(tensor,tensor_Inv)
c
c       implicit none
c       integer:: i, j, k , l     !iterators
c       integer:: n1               !matrix dimension
c       double precision, dimension(3,3,3,3)::tensor, tensor_Inv !4th order tensors
c       double precision, dimension(6,6)::A6x6, A6x6_inv         !Auxiliary 2D order
c
c        call T4th_2_Voig(tensor, A6x6)
c        A6x6_inv=inv_T_2D(dble(A6x6))
c        call Voig_2_T4th(A6x6_inv,tensor_Inv)
c
c      end subroutine invT4

c=======================================================================
c                    Function contrac_2nd_2nd
c=======================================================================
c=======================================================================
c Returns the contraction between two second order tensors
c-----------------------------------------------------------------------
cInputs
c    T_2D_1: 2nd order tensor
c    T_2D_2: 2nd order tensor
c------------------------------------------------------------------------
cOutput
c    Contr: result of the contraction, 0 order tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c===================================================================
      function contrac_2nd_2nd(T_2D_1, T_2D_2) result(Contr)

       implicit none
       double precision, dimension(:,:) :: T_2D_1, T_2D_2 !2nd order tensor
       double precision :: Contr !Result of the contraction
       integer:: i, j !Iterators
       integer:: n    !dimension tensor.

        Contr =0.00000000
        n=size(T_2D_1,1)

        do i=1,n
          do j=1,n
            Contr =Contr+ T_2D_1(j,i)*T_2D_2(j,i)
          end do
        end do

      end function contrac_2nd_2nd

c======================================================================
c                  Fucntion diadic_prod_T2_T2
c=======================================================================
c==================================================================
c Returns the diadic product between two second order tensors
c------------------------------------------------------------------]
cInputs
c    T_2D_1: 2nd order tensor
c    T_2D_2: 2nd order tensor
c    Diad: result of the diadic product, 4th order tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c===================================================================
      function diadic_prod_T2_T2(T_2D_1,T_2D_2) result(Diad)
        implicit none
        double precision, dimension(:,:) :: T_2D_1, T_2D_2  !2nd order tensor
        double precision, dimension(size(T_2D_1,1),size(T_2D_1,1),
     &                 size(T_2D_1,1),size(T_2D_1,1)):: Diad !4th order tensor
        integer:: i, j, k, l !Iterators
        integer:: n,n2       !size dimension tensor

        n=size(T_2D_1,1)
        n2=size(Diad,4)

        do i=1,n
            do j=1,n
                do k=1,n
                    do l=1,n
                      Diad(j,i,l,k) = T_2D_1(j,i)*T_2D_2(l,k)
                    end do
                  end do
                end do
              end do

      end function diadic_prod_T2_T2

c=======================================================================
c                    function contrac_4th_2nd
c=======================================================================
c=======================================================================
c Returns the contraction between a 4th order tensor a a 2nd order tensor
c-----------------------------------------------------------------------
cInputs
c    T_4th: 4th order tensor
c    T_2D: 2nd order tensor
c-----------------------------------------------------------------------
cOutput
c    Contr: result of the contraction, a 2nd order tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c=======================================================================
      function contrac_4th_2nd(T_4th,T_2D) result(Contr)
        implicit none
        double precision, dimension(3,3,3,3):: T_4th                      !2nd order tensor
        double precision, dimension(size(T_4th,3),size(T_4th,4)) ::T_2D
     $   , Contr                                                          !4th order tensor
        integer:: i, j, k, l
        integer:: n  !size dimension tensor

        n=size(T_4th,1)
        do i=1,3
            do j=1,3
                do k=1,3
                    do l=1,3
                      !Contr(j,i) =Contr(j,i)+T_4th(j,i,l,k)*T_2D(l,k)
                      Contr(i,j)= Contr(i,j)+T_4th(i,j,k,l)*T_2D(k,l)
                    end do
                  end do
                end do
              end do

      end function contrac_4th_2nd

c======================================================================
c                    subroutine Voig_2_T4th
c=======================================================================
c==================================================================
c  maps a 2D (6x6) tensor in voigth notation into a 4th order tensor
c------------------------------------------------------------------]
cInputs
c    tensor: 4th order tensor to map
c    T_2D: Voigth notation (6x6) 2nd order tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c===================================================================

      subroutine voig_2_T4th(T_2D, tensor_4th)
       implicit none

       integer:: i, j, k , l                            !iterators
       integer:: n1,n2,elements                         !dimension matrix
       integer, dimension(3,3)::nn                      !Auxiliar iterators
       double precision, dimension(6,6)::T_2D           !2nd order tensor
       double precision, dimension(6,6):: Aux,temp      !2nd order auxiliary tensor
       double precision, dimension(3,3,3,3)::tensor_4th !4th order
       double precision:: sq2, tem_n1, tem_n2           !Auxiliary scalars

       sq2 =2.00000**0.5
       tem_n1=1.0
       tem_n2=2.0

       Aux=reshape((
     &        / tem_n1,   tem_n1,   tem_n1, sq2,    sq2,    sq2,
     &          tem_n1,   tem_n1,   tem_n1, sq2,    sq2,    sq2,
     &          tem_n1,   tem_n1,   tem_n1, sq2,    sq2,    sq2,
     &          sq2,      sq2,      sq2,    tem_n2, tem_n2, tem_n2,
     &          sq2,      sq2,      sq2,    tem_n2, tem_n2, tem_n2,
     &          sq2,      sq2,      sq2,    tem_n2, tem_n2, tem_n2 /),
     &      shape(Aux), order=(/2,1/) )

        nn=reshape(( /1, 4, 6,
     &                4, 2, 5,
     &                6, 5, 3/),shape(nn), order =(/2,1/))

        do i=1,6
          do j=1,6
            temp(j,i)=0
            temp(j,i)=T_2D(j,i)/Aux(j,i)
          end do
        end do

        do i=1,3
          do j=1,3
            do k=1,3
              do l=1,3
                tensor_4th(i,j,l,k)=temp(nn(i,j),nn(l,k))
              end do
            end do
          end do
        end do
      end subroutine voig_2_T4th

c======================================================================
c                    subroutine T4th_2_Voig
c=======================================================================
c==================================================================
c  maps a 4th order tensor into a 2th order tensor according
cthe voight notation
c------------------------------------------------------------------]
cInputs
c    tensor: 4th order tensor to map
c    Vn_2D: kelvin notation 6x6 2nd order tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c===================================================================

      subroutine T4th_2_Voig(tensor_4th, Vn_2D)
        implicit none
        integer:: i, j, k , l                              !iterators
        integer:: n1,n2,elements                           !dimension matrix
        double precision, dimension(3,3,3,3)::tensor_4th   !4nd order tensor
        double precision, dimension(6,6)::Vn_2D            !2nd order tensor
        double precision:: sq2,const1                      !Auxiliary scalar

        sq2 =2.000000**0.5
        const1=2.000000
        elements=size(tensor_4th)
        n1=size(tensor_4th,1)
        n2=size(tensor_4th,2)
          if (elements .eq. 81) then
           Vn_2D=reshape( (
     &               /tensor_4th(1,1,1,1),         tensor_4th(1,1,2,2),
     &                tensor_4th(1,1,3,3),     sq2*tensor_4th(1,1,1,2),
     &            sq2*tensor_4th(1,1,2,3),     sq2*tensor_4th(1,1,1,3),
     &                tensor_4th(2,2,1,1),         tensor_4th(2,2,2,2),
     &                tensor_4th(2,2,3,3),     sq2*tensor_4th(2,2,1,2),
     &            sq2*tensor_4th(2,2,2,3),     sq2*tensor_4th(2,2,1,3),
     &                tensor_4th(3,3,1,1),         tensor_4th(3,3,2,2),
     &                tensor_4th(3,3,3,3),     sq2*tensor_4th(3,3,1,2),
     &            sq2*tensor_4th(3,3,2,3),     sq2*tensor_4th(3,3,1,3),
     &            sq2*tensor_4th(1,2,1,1),     sq2*tensor_4th(1,2,2,2),
     &            sq2*tensor_4th(1,2,3,3),  const1*tensor_4th(1,2,1,2),
     &              2*tensor_4th(1,2,2,3),  const1*tensor_4th(1,2,1,3),
     &            sq2*tensor_4th(2,3,1,1),     sq2*tensor_4th(2,3,2,2),
     &            sq2*tensor_4th(2,3,3,3),  const1*tensor_4th(2,3,1,2),
     &         const1*tensor_4th(2,3,2,3),  const1*tensor_4th(2,3,1,3),
     &            sq2*tensor_4th(1,3,1,1),     sq2*tensor_4th(1,3,2,2),
     &            sq2*tensor_4th(1,3,3,3),  const1*tensor_4th(1,3,1,2),
     &         const1*tensor_4th(1,3,2,3), const1*tensor_4th(1,3,1,3)/),
     &          shape(Vn_2D), order=(/2,1/) )

          end if

      end subroutine T4th_2_Voig

c======================================================================
c                    T2nd_2_Voig
c=======================================================================
c==================================================================
c  maps 2nd order tensor to 1st order tensor according the voight
cnotation
c------------------------------------------------------------------]
cInputs
c    T_2D: 6x6 2nd order tensor in voigth notation
c    T_1D: vector 6 size in voigth notation
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c===================================================================
      subroutine T2nd_2_Voig(T_2D,T_1D)

        implicit none
        integer:: i, j                          !iterators
        integer:: n1,n2,elements                !dimension matrix
        double precision, dimension(6,6)::T_2D  !2nd order tensor
        double precision, dimension(6)::T_1D    !1st order tensor
        double precision:: sq2                  !Auxiliar scalar

        sq2 =2.0**0.5
        elements=size(T_2D)
        if (elements==9) then

            T_1D=(/T_2D(1,1), T_2D(2,2), T_2D(3,3), sq2*T_2D(1,2),
     &         sq2*T_2D(2,3), sq2*T_2D(1,3)/)
        end if

      end subroutine T2nd_2_Voig

c======================================================================
c                    subroutine print_matrix
c=======================================================================
c==================================================================
c subroutine print in the terminal a 2D tensor of dimension n1 x n2
c------------------------------------------------------------------]
c Inputs
c   array:     array of size n1xn2
c   n1, n2 :   array dimensions
cc------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c==================================================================
      subroutine print_matrix(array,n1,n2)
        implicit none
        integer:: i, j     !iterators
        integer:: n1, n2  !dimension matrix
        double precision :: array(n1,n2) !2D test tensors

        do i=1,n1
          write(*,*) (array(i,j), j = lbound(array,2), ubound(array,2))
        end do
      end subroutine print_matrix

c======================================================================
c                    subroutine print_4D_tensor
c=======================================================================
c==================================================================
c Prints in the terminal a 4th grade tensor of dimension n1 x n1 x n1 x n1
c------------------------------------------------------------------]
cInputs
c    tensor :
c     n1 : size of the inner 2nd grade tensor
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c===================================================================
      subroutine print_4D_tensor(tensor,n1)
        implicit none
        integer:: i, j,k,l                            !iterators
        integer:: n1, n2                              !dimension matrix
        double precision , dimension(3,3,3,3)::tensor !4th order tensor

        print*,"tensor 4th grade"
        do i = 1,3
          do j = 1,3
            print*,"submatrix", j,",",i
            call print_matrix(tensor(j,i,:,:),n1,n1)
          end do
        end do

      end subroutine print_4D_tensor

c======================================================================
c                 Subroutine loading2
c=======================================================================
c==================================================================
c Return the ramp of the strain load for a strain driven tension test
c------------------------------------------------------------------
c Inputs
c       ltype: load tyoe
c           1. Simple load
c           2. Load and unload (only compression)
c           3.
c           4. Load and compression (full cycle)
c       posi_last_time: indeces that indicates the position in the vector
c       "t" of last data for each kind of load
c       dt: time step size
c       t: vector with the range of time for the load, its contents depends
c          on each load type
c       lam: vector with the range of strain for the load, its contents depends
c          on each load type
c       load : vector with the strain load ramp
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c==================================================================

      subroutine loading2(ltype,posi_last_time,dt,t,lam,load)
        !use tensor_operations

        implicit none
        integer:: ltype, type  !
        integer, dimension(5) :: posi_last_time
        integer::n_step_a, n_step_b, n_step_c
        double precision :: dt
        double precision, dimension(7) :: t
        double precision, dimension(3) ::lam
        double precision, dimension(:):: load
        double precision, dimension(:), allocatable :: xa, ya, xb, yb,
     $                                                 xc, yc
        double precision ::xa1, ya1, xb1, yb1, xc1, yc1
        double precision ::xa2, ya2, xb2, yb2, xc2, yc2
        print*, "Enter load general"

        !ltype==1 correspond to a load with one linear load
        if (ltype==1) then
          type=1
          n_step_a=nint((t(2)-t(1))/dt)
          allocate (xa(n_step_a+1))
          allocate (ya(n_step_a+1))

          xa1=t(1); ya1=lam(1)
          xa2=t(2); ya2=lam(2)
          call linespace(ya1,ya2,ya,type)

          load=ya
          deallocate(xa)
          deallocate(ya)

        !ltype==2 correspond to a semicycle with one linear load and a linear unload
        elseif (ltype==2) then
          type=1
          n_step_a=nint((t(2)-t(1))/dt)
          allocate (xa(n_step_a+1))
          allocate (ya(n_step_a+1))
          call linespace(t(1),t(2),xa,type)

          xa1=t(1); ya1=lam(1)
          xa2=t(2); ya2=lam(2)
          call linespace(ya1,ya2,ya,type)

          type=0
          n_step_b=nint((t(3)-t(2))/dt)
          allocate (xb(n_step_b))
          allocate (yb(n_step_b))
          call linespace(t(2),t(3),xb, type)
          xb1=t(2); yb1=lam(2)
          xb2=t(3); yb2=lam(1)
          yb=(yb2-yb1)/(xb2-xb1)*(xb-xb1)+yb1

          deallocate (xa)
          deallocate (xb)
          load=(/ya,yb/)
          deallocate (ya)
          deallocate (yb)
          print*, "End load 2"

        !ltype==4 correspond to a load with 1 load, 1 unload including
        ! a negative part and a load to the zero point
        elseif (ltype==4) then
          type=1
          n_step_a=nint((t(2)-t(1))/dt)
          allocate (xa(n_step_a+1))
          allocate (ya(n_step_a+1))
          call linespace(t(1),t(2),xa,type)

          xa1=t(1); ya1=lam(1)
          xa2=t(2); ya2=lam(2)
          call linespace(ya1,ya2,ya,type)

          type=0
          n_step_b=nint((t(3)-t(2))/dt)
          allocate (xb(n_step_b))
          allocate (yb(n_step_b))
          call linespace(t(2),t(3),xb, type)
          xb1=t(2); yb1=lam(2)
          xb2=t(3); yb2=lam(3)
          yb=(yb2-yb1)/(xb2-xb1)*(xb-xb1)+yb1

          n_step_c=nint((t(4)-t(3))/dt)
          allocate (xc(n_step_c))
          allocate (yc(n_step_c))
          call linespace(t(3),t(4),xc, type)
          xc1=t(3); yc1=lam(3)
          xc2=t(4); yc2=lam(1)
          yc=(yc2-yc1)/(xc2-xc1)*(xc-xc1)+yc1

          deallocate (xa)
          deallocate (xb)
          deallocate (xc)
          load=(/ya, yb, yc/)
          deallocate (ya)
          deallocate (yb)
          deallocate (yc)
          print*, "End load 4"

        end if
      end subroutine loading2

cc======================================================================
cc                    function partition_1D
cc=======================================================================
cc==================================================================
cc function partition_1D (T_1D)
cc------------------------------------------------------------------]
cc Inputs
cc   T_1D: 1st order tensor  dimension 1x6
cc-----------------------------------------------------------------
cc Outputs
cc   T_1D_Par: 1st order tensor  dimension 1x5
cc------------------------------------------------------------------------
cc coded by: W. Mora Sep 2021
cc==================================================================
c      function partition_1D(T_1D) result(T_1D_Par)
c
c        implicit none
c        double precision, dimension (6) ::T_1D
c        double precision, dimension (5) ::T_1D_Par
c
c        if (size(T_1D)==6) then
c            T_1D_Par=T_1D(2:)
c        end if
c      end function partition_1D
c
cc=======================================================================
cc                 function partition_2D_1D
cc=======================================================================
cc=======================================================================
cc returns a vecotr notation of a 3x3 simmetric 2nd order tensor without
cc  the element 1,1.
cc-----------------------------------------------------------------------
cc Inputs
cc   T_1D : 2 order symmetric tensor
cc-----------------------------------------------------------------------
cc Outputs
cc   T_1D_Par : 1st order voigth notation with out element 1,1.
cc------------------------------------------------------------------------
cc coded by: W. Mora Sep 2021
cc=======================================================================
c      function partition_2D_1D(T_2D) result(T_1D_Par)
c        implicit none
c
c        double precision, dimension (3,3) ::T_2D    !2nd order tensor
c        double precision, dimension (5) ::T_1D_Par  !1st order tensor
c
c        if (size(T_2D)==9) then
c            T_1D_Par=(/T_2D(2,2),
c     $                 T_2D(3,3),
c     $                 T_2D(1,2),
c     $                 T_2D(2,3),
c     $                 T_2D(1,3)/)
c        end if
c
c      end function partition_2D_1D
c
cc======================================================================
cc                 function partition_2D_2D
cc=======================================================================
cc==================================================================
cc returns a 2nd order tensor of dimension 5x5 from a 2nd order tensor of
cc dimension 6x6 without include the forst row and colum.
cc------------------------------------------------------------------]
cc Inputs
cc   T_2D: 2nd order tensor 5x5
cc-----------------------------------------------------------------
cc Outputs
cc   T_2D_Par: 2nd order tensor 6x6
cc------------------------------------------------------------------------
cc coded by: W. Mora Sep 2021
cc==================================================================
c
c      function partition_2D_2D(T_2D) result(T_2D_Par)
c        implicit none
c
c        double precision, dimension (6,6) ::T_2D     !2nd order tensor
c        double precision, dimension (5,5) ::T_2D_Par !2nd order tensor
c
c        if (size(T_2D)==36) then
c          T_2D_Par=reshape(
c     $       (/T_2D(2,2), T_2D(2,3), T_2D(2,4), T_2D(2,5), T_2D(2,6),
c     $         T_2D(3,2), T_2D(3,3), T_2D(3,4), T_2D(3,5), T_2D(3,6),
c     $         T_2D(4,2), T_2D(4,3), T_2D(4,4), T_2D(4,5), T_2D(4,6),
c     $         T_2D(5,2), T_2D(5,3), T_2D(5,4), T_2D(5,5), T_2D(5,6),
c     $         T_2D(6,2), T_2D(6,3), T_2D(6,4), T_2D(6,5), T_2D(6,6)/),
c     $          shape(T_2D_Par),order=(/2,1/))
c        end if
c
c      end function partition_2D_2D

c======================================================================
c                 function Kron_d
c=======================================================================
c==================================================================
c returns the evaluation of the Kronecker delta function given the indices.
c------------------------------------------------------------------]
c Inputs
c   i:index 1
c   j:index 2
c-----------------------------------------------------------------
c Outputs
c   kd_ij: result of the evaluation
c------------------------------------------------------------------------
c coded by: W. Mora Oct 2021
c==================================================================

      function Kron_d(i,j) result(kd_ij)
        implicit none

        integer::i, j
        double precision :: kd_ij
        if (i==j) then
          kd_ij=1.0
        else
          kd_ij=0.0
        end if
      end function Kron_d

      end module tensor_operations

c=======================================================================
c            SUBROUTINES TO MAKE THE TEST
C=======================================================================

c======================================================================
c                 subroutine read2
c=======================================================================
c==================================================================
c Import the data form a csv file
c------------------------------------------------------------------]
c Inputs
c   import1   : 2D rank tensor to store the readed information
c   n1        : dimesion 1 of the array that contain the information
c   n2        : dimesion 2 of the array that contain the information
c   file_name : information source file name. (must be a csv file)
c------------------------------------------------------------------------
c coded by: W. Mora Oct 2021
c==================================================================

      subroutine read2(import1, n1,n2, file_name)
          implicit none
          integer:: i, j,end,stat,line_no,n1,n2     !iterators

          character(len=13) :: file_name
          double precision :: import1(n1,n2)
          n1=size(import1,1)
          n2=size(import1,2)

          open(15, file=file_name,access='sequential',
     &      form="formatted", iostat=stat)
          do i = 1,n1
             read(15,*,iostat=stat) import1(i,:)
          end do
          close (15)

      end subroutine read2

      subroutine emp_4th(T_4th)
        implicit none
        double precision, dimension(3,3,3,3):: T_4th                      !2nd order tensor
        double precision, dimension(size(T_4th,3),size(T_4th,4)) ::T_2D
     $   , Contr                                                          !4th order tensor
        integer:: i, j, k, l
        integer:: n  !size dimension tensor

        n=size(T_4th,1)
        do i=1,3
            do j=1,3
                do k=1,3
                    do l=1,3
                      !Contr(j,i) =Contr(j,i)+T_4th(j,i,l,k)*T_2D(l,k)
                      T_4th= 0.000
                    end do
                  end do
                end do
              end do

            end subroutine emp_4th

      subroutine emp_2D(T)
        implicit none
        double precision, dimension(3,3):: T   !2nd order tensor
        integer:: i, j
        integer:: n  !size dimension tensor

        do i=1,3
            do j=1,3
              T= 0.000

          end do
        end do

      end subroutine emp_2D