*DECK ALNGAM
      FUNCTION ALNGAM (X)
C***BEGIN PROLOGUE  ALNGAM
C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
C            function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A
C***TYPE      SINGLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C)
C***KEYWORDS  ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ALNGAM(X) computes the logarithm of the absolute value of the
C gamma function at X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  GAMMA, R1MACH, R9LGMC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  ALNGAM
      LOGICAL FIRST
      EXTERNAL GAMMA
      SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST
      DATA SQ2PIL / 0.9189385332 0467274E0/
      DATA SQPI2L / 0.2257913526 4472743E0/
      DATA PI     / 3.1415926535 8979324E0/
      DATA FIRST  /.TRUE./
C***FIRST EXECUTABLE STATEMENT  ALNGAM
      IF (FIRST) THEN
         XMAX = R1MACH(2)/LOG(R1MACH(2))
         DXREL = SQRT (R1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.10.0) GO TO 20
C
C LOG (ABS (GAMMA(X))) FOR  ABS(X) .LE. 10.0
C
      ALNGAM = LOG (ABS (GAMMA(X)))
      RETURN
C
C LOG (ABS (GAMMA(X))) FOR ABS(X) .GT. 10.0
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'ALNGAM',
     +   'ABS(X) SO BIG ALNGAM OVERFLOWS', 2, 2)
C
      IF (X.GT.0.) ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y)
      IF (X.GT.0.) RETURN
C
      SINPIY = ABS (SIN(PI*Y))
      IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'ALNGAM',
     +   'X IS A NEGATIVE INTEGER', 3, 2)
C
      IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
     +   'ALNGAM', 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR ' //
     +   'NEGATIVE INTEGER', 1, 1)
C
      ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y)
      RETURN
C
      END


! { dg-do compile }

module yemdyn
   implicit none
   integer, parameter :: jpim = selected_int_kind(9)
   integer, parameter :: jprb = selected_real_kind(13,300)
   real(kind=jprb) :: elx
   real(kind=jprb), allocatable :: xkcoef(:)
   integer(kind=jpim),allocatable :: ncpln(:), npne(:)
end module yemdyn

subroutine suedyn

   use yemdyn

   implicit none

   integer(kind=jpim) :: jm, jn
   real(kind=jprb) :: zjm, zjn, zxxx

   jn=0
   do jm=0,ncpln(jn)
      zjm=real(jm,jprb) / elx
      xkcoef(npne(jn)+jm) = - zxxx*(zjm**2)**0.5_jprb
   end do

end subroutine suedyn


c=======================================================================
c
c     subroutine COSKEW
c
c     Empirical CoSkewness matrix, p by (p*p)
c
c     Statistical measure that calculates the symmetry of a variable's
c     probability distribution in relation to another variable's probability
c     distribution symmetry. All else being equal, a positive coskewness
c     means that the first variable's probability distribution is skewed
c     to the right of the second variable's distribution.
c
c     In finance, coskewness can be used as a supplement to the covariance
c     calculation of risk estimation. Usually, coskewness is calculated
c     using a security's historic price data as the first variable,
c     and the market's historic price data as the second. This provides
c     an estimation of the security's risk in relation to market risk.
c
c     An investor would prefer a positive coskewness because this represents
c     a higher probability of extreme positive returns in the security
c     over market returns.
c
c                           n
c                      1   ---            -                 -                 -
c     coskew(i,j,k) = ---   \   [X(t,i) - X(i)] * [X(t,j) - X(j)] * [X(t,k) - X(k)]
c                      n    /
c                           ---
c                           t=1
c     where
c
c                  n
c       -      1  ---
c       X(j) = -  \   X(i,j) for j = 1,...,p
c              n  /
c                 ---
c                 i=1
c
c     Note: In co-Skewness only (n+2)(n+1)n/6 elements must be computed.
c
c-----------------------------------------------------------------------
      SUBROUTINE coskew ( n, p, X, dwork, coskewness, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n           : number of value(s) (n > 1)                 integer
c       p           : number of asset(s) (p >= 1)                integer
c       X           : value(s) (n*p)                              double
c
c     WORKSPACE
c       dwork       : vector( p*n +p)                             double
c
c     OUTPUT
c        coskewness : empirical skewness matrix (p*p*p)           double
c        info       : diagnostic argument                        integer
c
c     CALL
c        TENSORK    : estimation of co-Skewness[k] matrix
c        YM         : matrix copy
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION X(*), coskewness(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER k, pdtensor, pdHk
c
c     external subroutines
      EXTERNAL TENSORK, YM
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdtensor = 1
c     pdtensor: pointer for TENSORK (p)
      pdHk     = pdtensor + ( p )
c     pdHk    : pointer for Hk tensor ( p*p )
c
c     Total size of dwork array = p*(p + 1)
c
c----------------------------------------------------------------------
c
c     loop
      DO k = 1,p
c       tensor H[k]
        CALL TENSORK ( n, p, k, X, dwork(pdtensor), dwork(pdHk), info)
        IF (info .LT. 0) RETURN
c
        CALL YM ( p, p, dwork(pdHk), coskewness(1+(k-1)*p*p) )
      ENDDO
c
      RETURN
      END


module dists
  use globvars, only: dp, sp, ip, pi_dp, pi_sp
  use numerics, only: numerics_factorial, numerics_beta, &
       numerics_binomial_coeff

  implicit none

  private

  public :: dists_hypergeometric
  interface dists_hypergeometric
     module procedure dists_hypergeometric_dp
     module procedure dists_hypergeometric_sp
  end interface dists_hypergeometric

  public :: dists_poisson
  interface dists_poisson
     module procedure dists_poisson_dp
     module procedure dists_poisson_sp
  end interface dists_poisson

  public :: dists_laplace
  interface dists_laplace
     module procedure dists_laplace_dp
     module procedure dists_laplace_sp
  end interface dists_laplace

  public :: dists_lognormal
  interface dists_lognormal
     module procedure dists_lognormal_dp
     module procedure dists_lognormal_sp
  end interface dists_lognormal

  public :: dists_weibull
  interface dists_weibull
     module procedure dists_weibull_dp
     module procedure dists_weibull_sp
  end interface dists_weibull

  public :: dists_exp
  interface dists_exp
     module procedure dists_exp_dp
     module procedure dists_exp_sp
  end interface dists_exp

  public :: dists_chi2
  interface dists_chi2
     module procedure dists_chi2_dp
     module procedure dists_chi2_sp
  end interface dists_chi2

  public :: dists_f
  interface dists_f
     module procedure dists_f_dp
     module procedure dists_f_sp
  end interface dists_f

  public :: dists_cauchy
  interface dists_cauchy
     ! Cauchy distribution
     module procedure dists_cauchy_dp
     module procedure dists_cauchy_sp
  end interface dists_cauchy

  public :: dists_gamma
  interface dists_gamma
     ! Gamma distribution
     module procedure dists_gamma_dp
     module procedure dists_gamma_sp
  end interface dists_gamma

  public :: dists_t
  interface dists_t
     ! Student's t distribution
     module procedure dists_t_dp
     module procedure dists_t_sp
  end interface dists_t

  public :: dists_binomial
  interface dists_binomial
     ! Binomial distribution:
     !
     ! B(x) = (n k) p^k (1-p)^(n-k)
     module procedure dists_binomial_dp
     module procedure dists_binomial_sp
  end interface dists_binomial

  public :: dists_gaussian
  interface dists_gaussian
     ! Normalized Gaussian distribution:
     !
     ! G(x) = 1 / sqrt( 2 pi sig^2 ) exp( -1/2 (x - mu)^2 / sig^2 )
     !
     ! See documentation for specific module procedures for more details
     module procedure dists_gaussian_dp
     module procedure dists_gaussian_sp
  end interface dists_gaussian

  real(dp), parameter :: tau_dp = 2.0_dp * pi_dp
  real(sp), parameter :: tau_sp = 2.0_sp * pi_sp

contains

  pure real(dp) function dists_hypergeometric_dp(n, k, NN, KK, fp_cnst) &
       result(val)
    ! Hypergeometric distribution that returns double precision real values
    !
    ! n :: # of draws
    ! k :: # of successes
    ! NN :: population size
    ! KK :: # of success states
    ! kind :: output precision
    ! fp_cnst :: double precision number to return correct type from interface
    integer(ip), intent(in) :: n
    integer(ip), intent(in) :: k
    integer(ip), intent(in) :: NN
    integer(ip), intent(in) :: KK
    real(dp), intent(in) :: fp_cnst

    include "./dists_src/hypergeometric.src"
  end function dists_hypergeometric_dp

  pure real(sp) function dists_hypergeometric_sp(n, k, NN, KK, fp_cnst) &
       result(val)
    ! Duplicate of dists_hypergeometric_dp, but for single precision reals
    integer(ip), intent(in) :: n
    integer(ip), intent(in) :: k
    integer(ip), intent(in) :: NN
    integer(ip), intent(in) :: KK
    real(sp), intent(in) :: fp_cnst

    include "./dists_src/hypergeometric.src"
  end function dists_hypergeometric_sp

  pure real(dp) function dists_poisson_dp(k, lambda) result(val)
    ! Poisson distribution for double precision real values
    !
    ! k :: observed events in interval
    ! lambda :: Average # of events per interval
    integer(ip), intent(in) :: k
    real(dp), intent(in) :: lambda

    include "./dists_src/poisson.src"
  end function dists_poisson_dp

  pure real(sp) function dists_poisson_sp(k, lambda) result(val)
    ! Duplicate of dists_poisson_dp, but for single precision reals
    integer(ip), intent(in) :: k
    real(sp), intent(in) :: lambda

    include "./dists_src/poisson.src"
  end function dists_poisson_sp

  pure real(dp) function dists_laplace_dp(x, mu, b) result(val)
    ! Laplace (double exponential) distribution for double precision real
    ! values
    !
    ! x :: evaluation point
    ! mu :: location parameter
    ! b :: scale parameter > 0
    real(dp), intent(in) :: x
    real(dp), intent(in) :: mu
    real(dp), intent(in) :: b

    include "./dists_src/laplace.src"
  end function dists_laplace_dp

  pure real(sp) function dists_laplace_sp(x, mu, b) result(val)
    ! Duplicate of dists_laplace_dp, but for single precision reals
    real(sp), intent(in) :: x
    real(sp), intent(in) :: mu
    real(sp), intent(in) :: b

    include "./dists_src/laplace.src"
  end function dists_laplace_sp

  pure real(dp) function dists_lognormal_dp(x, mu_var, var_var) result(val)
    ! Lognormal distribution for double precision real values
    !
    ! x :: evaluation point
    ! mu_var :: mean of variance
    ! var_var :: variance of variance
    real(dp), intent(in) :: x
    real(dp), intent(in) :: mu_var
    real(dp), intent(in) :: var_var

    include "./dists_src/lognormal.src"
  end function dists_lognormal_dp

  pure real(sp) function dists_lognormal_sp(x, mu_var, var_var) result(val)
    ! Duplicate of dists_lognormal_sp, but for single precision real values
    real(sp), intent(in) :: x
    real(sp), intent(in) :: mu_var
    real(sp), intent(in) :: var_var

    include "./dists_src/lognormal.src"
  end function dists_lognormal_sp

  pure real(dp) function dists_weibull_dp(x, lambda, k) result(val)
    ! Weibull distribution for double precision real values
    !
    ! x :: evaluation point, x > 0
    ! lambda :: shape parameter, k > 0
    ! lambda :: scale parameter, lambda > 0
    real(dp), intent(in) :: x
    real(dp), intent(in) :: lambda
    real(dp), intent(in) :: k

    include "./dists_src/weibull.src"
  end function dists_weibull_dp

  pure real(dp) function dists_weibull_sp(x, lambda, k) result(val)
    ! Duplicate of dists_weibull_sp, but for single precision real values
    real(sp), intent(in) :: x
    real(sp), intent(in) :: lambda
    real(sp), intent(in) :: k

    include "./dists_src/weibull.src"
  end function dists_weibull_sp

  pure real(dp) function dists_exp_dp(x, lambda) result(val)
    ! Exponential distribution for double precision real values
    !
    ! x :: evaluation point, x >= 0
    ! lambda :: rate parameter, lambda > 0
    real(dp), intent(in) :: x
    real(dp), intent(in) :: lambda

    include "./dists_src/exp.src"
  end function dists_exp_dp

  pure real(dp) function dists_exp_sp(x, lambda) result(val)
    ! Duplicate of dists_exp_dp, but for single precision values
    real(sp), intent(in) :: x
    real(sp), intent(in) :: lambda

    include "./dists_src/exp.src"
  end function dists_exp_sp

  pure real(dp) function dists_chi2_dp(x, k) result(val)
    ! Chi-squared distribution for double precision real values
    !
    ! x :: evaluation point
    ! k :: degrees of freedom
    real(dp), intent(in) :: x
    integer(ip), intent(in) :: k

    real(dp) :: k_2_fp
    real(dp) :: numer
    real(dp) :: denom

    k_2_fp = k / 2.0_dp

    include "./dists_src/chi2.src"
  end function dists_chi2_dp

  pure real(dp) function dists_chi2_sp(x, k) result(val)
    ! Duplicate of dists_chi2_dp, but for single precision real values
    real(sp), intent(in) :: x
    integer(ip), intent(in) :: k

    real(sp) :: k_2_fp
    real(sp) :: numer
    real(sp) :: denom

    k_2_fp = k / 2.0_sp

    include "./dists_src/chi2.src"
  end function dists_chi2_sp

  pure real(dp) function dists_f_dp(x, d1, d2) result(val)
    ! F distribution for double precision real values
    !
    ! x :: evaluation point
    ! d1 :: 1st shape parameter
    ! d2 :: 2nd shaper parameter
    real(dp), intent(in) :: x
    real(dp), intent(in) :: d1
    real(dp), intent(in) :: d2

    real(dp) :: numer
    real(dp) :: denom

    include "./dists_src/f.src"
  end function dists_f_dp

  pure real(sp) function dists_f_sp(x, d1, d2) result(val)
    ! Duplicate of dists_f_dp, but for single precision values
    real(sp), intent(in) :: x
    real(sp), intent(in) :: d1
    real(sp), intent(in) :: d2

    real(sp) :: numer
    real(sp) :: denom

    include "./dists_src/f.src"
  end function dists_f_sp

  pure real(dp) function dists_cauchy_dp(x, x0, gamma) result(val)
    ! Cauchy distribution for double precision values
    !
    ! x :: evaluation point
    ! x0 :: location parameter
    ! gamma :: scale parameter
    real(dp), intent(in) :: x
    real(dp), intent(in) :: x0
    real(dp), intent(in) :: gamma

    real(dp), parameter :: pi_fp = pi_dp

    include "./dists_src/cauchy.src"

  end function dists_cauchy_dp

  pure real(sp) function dists_cauchy_sp(x, x0, gamma) result(val)
    ! Duplicate of dists_cauchy_dp, but for single precision values
    ! gamma :: scale parameter
    real(sp), intent(in) :: x
    real(sp), intent(in) :: x0
    real(sp), intent(in) :: gamma

    real(sp), parameter :: pi_fp = pi_sp

    include "./dists_src/cauchy.src"

  end function dists_cauchy_sp

  pure real(dp) function dists_binomial_dp(k, n, p) result(val)
    ! Binomial distribution for double precision values
    !
    ! k :: successes
    ! n :: tries
    ! p :: probability of success
    integer(ip), intent(in) :: k
    integer(ip), intent(in) :: n
    real(dp), intent(in) :: p

    real(dp) :: p_f

    p_f = 1.0_dp - p

    include "./dists_src/binomial.src"
  end function dists_binomial_dp

  pure real(sp) function dists_binomial_sp(k, n, p) result(val)
    ! Duplicate of dists_binomial_sp, but for single precision values
    integer(ip), intent(in) :: k
    integer(ip), intent(in) :: n
    real(sp), intent(in) :: p

    real(sp) :: p_f

    p_f = 1.0_sp - p

    include "./dists_src/binomial.src"
  end function dists_binomial_sp

  pure real(dp) function dists_gamma_dp(x, k, theta) result(val)
    ! Gamma distribution for double precision real values
    !
    ! x :: evaluation point
    ! k :: shape parameter, k > 0
    ! theta :: scale parameter, theta > 0
    real(dp), intent(in) :: x
    real(dp), intent(in) :: k
    real(dp), intent(in) :: theta

    real(dp) :: numer
    real(dp) :: denom

    include "./dists_src/gamma.src"
  end function dists_gamma_dp

  pure  real(sp) function dists_gamma_sp(x, k, theta) result(val)
    ! Duplicate of dists_gamma, but for single precision values
    real(sp), intent(in) :: x
    real(sp), intent(in) :: k
    real(sp), intent(in) :: theta

    real(sp) :: numer
    real(sp) :: denom

    include "./dists_src/gamma.src"
  end function dists_gamma_sp

  pure real(dp) function dists_t_dp(t, n) result(val)
    ! Student's t distribution for double precision real values
    !
    ! t :: t value
    ! n :: degrees of freedom
    real(dp), intent(in) :: t
    integer(ip), intent(in) :: n

    real(dp) :: term1
    real(dp) :: term2
    real(dp) :: nu
    real(dp), parameter :: pi_fp = pi_dp

    nu = real(n - 1, kind=dp)

    include "./dists_src/t.src"
  end function dists_t_dp

  pure real(sp) function dists_t_sp(t, n) result(val)
    ! Duplicate of dists_t_sp, but for single precision values
    real(sp), intent(in) :: t
    integer(ip), intent(in) :: n

    real(sp) :: term1
    real(sp) :: term2
    real(sp) :: nu
    real(sp), parameter :: pi_fp = pi_sp

    nu = real(n - 1, kind=sp)

    include "./dists_src/t.src"
  end function dists_t_sp

  pure real(dp) function dists_gaussian_dp(x, mu, var) result(val)
    ! Normalized Gaussian distribution for double precision values
    !
    ! x :: evaluation point
    ! mu :: distribution mean
    ! var :: distribution variance
    real(dp), intent(in) :: x
    real(dp), intent(in) :: mu
    real(dp), intent(in) :: var

    real(dp) :: norm2, exp1

    norm2 = tau_dp * var

    include "./dists_src/gaussian.src"
  end function dists_gaussian_dp

  pure real(sp) function dists_gaussian_sp(x, mu, var) result(val)
    ! Duplicate of dists_gaussian_dp, but for single precision reals
    real(sp), intent(in) :: x
    real(sp), intent(in) :: mu
    real(sp), intent(in) :: var

    real(sp) :: norm2, exp1

    norm2 = tau_sp * var

    include "./dists_src/gaussian.src"
  end function dists_gaussian_sp

end module dists


program UnrollTest
    implicit none
    integer :: loopUpperBound
    integer:: i, j, k, m
    integer, parameter :: N = 512
    real:: a(N,N), b(N,N), c(N,N)
    real :: t1,t2,ta
    do j=1,N
        do i=1,N
            a(i,j)=i+j
            b(i,j)=i*j
        end do
    end do

    call cpu_time(t1)
    do m=1,100
        do i=1,N
            do j=1,N
                c(i,j)=0.0
                loopUpperBound = N
                !$xev loop_tag
                do k=1, loopUpperBound
                    c(i,j)=c(i,j)+b(k,j)*a(i,k)
                end do
            end do
        end do
    end do
    call cpu_time(t2)
    ta=real(t2-t1)/100
    print *,  ta
end program UnrollTest


module mod_chkdiv
  use mpi
  use mod_common_mpi, only: ierr
  use mod_types
  implicit none
  private
  public chkdiv
  contains
  subroutine chkdiv(lo,hi,dli,dzfi,u,v,w,divtot,divmax)
    !
    ! checks the divergence of the velocity field
    !
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(3) :: dli
    real(rp), intent(in), dimension(lo(3)-1:) :: dzfi
    real(rp), intent(in), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:) :: u,v,w
    real(rp), intent(out) :: divtot,divmax
    real(rp) :: dxi,dyi,div!,dzi
    integer :: i,j,k
    !
    dxi = dli(1)
    dyi = dli(2)
    !dzi = dli(3)
    divtot = 0.
    divmax = 0.
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(lo,hi,u,v,w,dxi,dyi,dzfi) &
    !$OMP PRIVATE(i,j,k,div) &
    !$OMP REDUCTION(+:divtot) &
    !$OMP REDUCTION(max:divmax)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          div = (w(i,j,k)-w(i,j,k-1))*dzfi(k) + &
                (v(i,j,k)-v(i,j-1,k))*dyi     + &
                (u(i,j,k)-u(i-1,j,k))*dxi
          divmax = max(divmax,abs(div))
          divtot = divtot + div
          !if(abs(div) >= 1.e-12) print*,div,'Large divergence at grid cell: ',i,j,k,div
        end do
      end do
    end do
    !$OMP END PARALLEL DO
    call mpi_allreduce(MPI_IN_PLACE,divtot,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
    call mpi_allreduce(MPI_IN_PLACE,divmax,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
  end subroutine chkdiv
end module mod_chkdiv


SUBROUTINE p65(input_file,output_file)
!-------------------------------------------------------------------------
! Program 6.5 Plane strain earth pressure analysis of an elastic-plastic
!             (Mohr-Coulomb) material using 8-node rectangular
!             quadrilaterals. Initial stress method.
!-------------------------------------------------------------------------
 USE main
 USE geom
  IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file

 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,incs,iters,iy,k,limit,ndim=2,ndof=16,nels, &
   neq,nip=4,nlen,nn,nod=8,nodof=2,nprops=7,np_types,nr,nst=4,nxe,nye
 REAL(iwp)::c,det,dsbar,e,f,fac,fnew,gamma,k0,lode_theta,one=1.0_iwp,ot,  &
   pav,phi,psi,pr,presc,pt5=0.5_iwp,sigm,penalty=1.0e20_iwp,tol,v,          &
   zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
 LOGICAL::converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   no(:),node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::bdylds(:),bee(:,:),bload(:),coord(:,:),dee(:,:),  &
   der(:,:),deriv(:,:),eld(:),eload(:),elso(:),eps(:),fun(:),gc(:),       &
   g_coord(:,:),jac(:,:),km(:,:),kv(:),loads(:),oldis(:),pl(:,:),         &
   points(:,:),prop(:,:),react(:),rload(:),sigma(:),storkv(:),stress(:),  &
   tensor(:,:,:),totd(:),weights(:),x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),weights(nip),g_coord(ndim,nn),    &
   x_coords(nxe+1),y_coords(nye+1),num(nod),dee(nst,nst),fun(nod),        &
   tensor(nst,nip,nels),g_g(ndof,nels),coord(nod,ndim),stress(nst),       &
   jac(ndim,ndim),der(ndim,nod),deriv(ndim,nod),g_num(nod,nels),          &
   bee(nst,ndof),km(ndof,ndof),eld(ndof),eps(nst),sigma(nst),bload(ndof), &
   eload(ndof),pl(nst,nst),elso(nst),g(ndof),gc(ndim),rload(ndof),        &
   prop(nprops,np_types),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq),bdylds(0:neq),oldis(0:neq),totd(0:neq), &
   react(0:neq))
   kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I7))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 CALL sample(element,points,weights)
 tensor=zero
 kv=zero
!-----------------------element stiffness integration and assembly--------
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(6,etype(iel)),prop(7,etype(iel)))
   gamma=prop(4,etype(iel))
   k0=prop(5,etype(iel))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_fun(fun,points,i)
     gc=MATMUL(fun,coord)
     tensor(2,i,iel)=(gc(2)-y_coords(1))*gamma
     tensor(1,i,iel)=(gc(2)-y_coords(1))*gamma*k0
     tensor(4,i,iel)=tensor(1,i,iel)
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(matmul(transpose(bee),dee),bee)*det*weights(i)
   END DO gauss_pts_1
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
!-----------------------read displacement data and factorise equations----
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),sense(fixed_freedoms),no(fixed_freedoms),&
     storkv(fixed_freedoms))
   READ(10,*)(node(i),sense(i),i=1,fixed_freedoms)
   DO i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   kv(kdiag(no))=kv(kdiag(no))+penalty
   storkv=kv(kdiag(no))
 END IF
 CALL sparin(kv,kdiag)
!-----------------------displacement increment loop-----------------------
 READ(10,*)tol,limit,incs,presc
 WRITE(11,'(/A)')                                                         &
   "  step   disp      load(av)    load(react)   moment    iters"
 oldis=zero
 totd=zero
 bdylds=zero
 disp_incs: DO iy=1,incs
   iters=0
   react=zero
!-----------------------plastic iteration loop----------------------------
   its: DO
     iters=iters+1
     loads=bdylds
     WRITE(*,'(A,E11.3,A,I4)')"  disp",iy*presc,"  iteration",iters
     DO i=1,fixed_freedoms
       loads(nf(1,node(i)))=storkv(i)*presc
     END DO
     CALL spabac(kv,loads,kdiag)
     bdylds=zero
!-----------------------check plastic convergence-------------------------
     CALL checon(loads,oldis,tol,converged)
     IF(iters==1)converged=.FALSE.
!-----------------------go round the Gauss Points ------------------------
     elements_3: DO iel=1,nels
       phi=prop(1,etype(iel))
       c=prop(2,etype(iel))
       psi=prop(3,etype(iel))
       e=prop(6,etype(iel))
       v=prop(7,etype(iel))
       CALL deemat(dee,e,v)
       bload=zero
       rload=zero
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       g=g_g(:,iel)
       eld=loads(g)
       gauss_pts_2: DO i=1,nip
         CALL shape_der(der,points,i)
         jac=MATMUL(der,coord)
         det=determinant(jac)
         CALL invert(jac)
         deriv=MATMUL(jac,der)
         CALL beemat(bee,deriv)
         eps=MATMUL(bee,eld)
         sigma=MATMUL(dee,eps)
         stress=sigma+tensor(:,i,iel)
         CALL invar(stress,sigm,dsbar,lode_theta)
!-----------------------check whether yield is violated-------------------
         CALL mocouf(phi,c,sigm,dsbar,lode_theta,fnew)
         elso=zero
         IF(fnew>zero)THEN
           stress=tensor(:,i,iel)
           CALL invar(stress,sigm,dsbar,lode_theta)
           CALL mocouf(phi,c,sigm,dsbar,lode_theta,f)
           fac=fnew/(fnew-f)
           stress=(one-fac)*sigma+tensor(:,i,iel)
           CALL mcdpl(phi,psi,dee,stress,pl)
           pl=fac*pl
           elso=MATMUL(pl,eps)
           eload=MATMUL(elso,bee)
           bload=bload+eload*det*weights(i)
         END IF
!-----------------------update the Gauss Point stresses-------------------
         IF(converged.OR.iters==limit)THEN
           tensor(:,i,iel)=tensor(:,i,iel)+sigma-elso
           rload=rload+MATMUL(tensor(:,i,iel),bee)*det*weights(i)
         END IF
       END DO gauss_pts_2
!-----------------------compute the total bodyloads vector ---------------
       bdylds(g)=bdylds(g)+bload
       react(g)=react(g)+rload
       bdylds(0)=zero
       react(0)=zero
     END DO elements_3
     IF(converged.OR.iters==limit)EXIT
   END DO its
   totd=totd+loads
   pr=zero
   ot=zero
   pav=zero
   DO i=1,fixed_freedoms
     pr=pr+react(no(i))
     ot=ot+react(no(i))*g_coord(2,node(i))
   END DO
   DO i=1,4
     pav=pav+(y_coords(i)-y_coords(i+1))*(tensor(1,1,i)+tensor(1,3,i))*pt5
   END DO
   WRITE(11,'(I5,4E12.4,I5)')iy,iy*presc,-pav,pr,ot,iters
   IF(iters==limit)EXIT
 END DO disp_incs
 CALL dismsh(totd,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(totd,nf,0.05_iwp,0.5_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p65


 implicit none

 integer :: i,nloop
 real(8) :: sum
 real    :: time0,time1

 print*,'Number of operations in each loop'; read*,nloop

 sum=0.0_8; call cpu_time(time0)
 do i=1,nloop
   sum=sum+dble(i)*dble(i)
 end do
 print*,sum
 call cpu_time(time1); print*,'Time used for s=s+i*i     : ',time1-time0
 sum=0.0_8; call cpu_time(time0)
 do i=1,nloop
   sum=sum+sqrt(dble(i))
 end do
 print*,sum
 call cpu_time(time1); print*,'Time used for s=s+sqrt(i) : ',time1-time0

 sum=0.0_8; call cpu_time(time0)
 do i=1,nloop
   sum=sum+log(dble(i))
 end do
 print*,sum
 call cpu_time(time1); print*,'Time used for s=s+log(i)  : ',time1-time0

 sum=0.0_8; call cpu_time(time0)
 do i=1,nloop
   sum=sum+exp(1.d0/dble(i))
 end do
 print*,sum
 call cpu_time(time1); print*,'Time used for s=s+exp(1/i)  : ',time1-time0

 sum=0.0_8; call cpu_time(time0)
 do i=1,nloop
   sum=sum+cos(dble(i))
 end do
 print*,sum
 call cpu_time(time1); print*,'Time used for s=s+cos(i)  : ',time1-time0

 end


program Complejos

implicit none

!complex:: z1,z2,z3
!complex(kind=4):: z1,z2,z3
!complex(kind=8):: z1,z2,z3
Double complex:: z1,z2,z3
real::a,b
!real(kind=8):: a,b

print*, "Esteprograma realiza operaciones basicas con numeros complejos"

print*, "favor de ingresar z1"
read*, z1
!lectura de z1 (real,imaginario)

print*, "Favor de ingresar el valor real de z2"
read*, a
print*, "favor de ingresar el valor imaginario de z2"
read*, b

z2=cmplx(a,b)

print*, "la suma de z1+z2 es"
z3=z1+z2
print*, z3

print*, "la resta de z1-z2 es"
z3=z1-z2
print*, z3

print*, "la multiplicacion de z1*z2 es"
z3=z1*z2
print*, z3

print*, "la división de z1/z2 es"
z3=z1/z2
print*, z3

print*, "el producto escalar de 5 * z1 es"
z3=5.0*z1
print*, z3

PAUSE
end program Complejos