      subroutine gesum(conc,delam,elam,elsump,elsums,elsumw,
     $ fxi,narn1,narn2,nazpmx,nstmax,zchar)
c
c     This subroutine calculates three second order sums involving the
c     E-lambda function (elam) and its ionic strength derivatives
c     (delam). These are used in Pitzer's equations. These
c     sums are:
c
c       elsumw: SUM(ij) [E-lambda(ij) + I*E-lambda'(ij)]*m(i)*m(j)
c
c       elsums: SUM(ij) E-lambda'(ij)*m(i)*m(j)
c
c       elsump: SUM(ij) E-lambda''(ij)*m(i)*m(j) [Not used]
c
c     Here ij refers to any species pair, but non-zero
c     contributions only arise from cc' and aa' pairs. Note that:
c
c       elsumw = 2*
c             [SUM(c'>c) {E-theta(cc') + I*E-theta'(cc')}m(c)m(c')
c            + SUM(a'>a) {E-theta(aa') + I*E-theta'(aa')}m(a)m(a')]
c
c       elsums = 2*[SUM(c'>c) E-theta'(cc')m(c)m(c')
c                 + SUM(a'>a) E-theta'(aa')m(a)m(a')]
c
c       elsump = 2*[SUM(c'>c) E-theta''(cc')m(c)m(c')
c                 + SUM(a'>a) E-theta''(aa')m(a)m(a')] [Not used]
c
c     This subroutine is called by:
c
c       EQLIBG/gcoeff.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       conc   = array of concentrations
c       elam   = array of E-lambda functions
c       delam  = array of ionic strength derivatives of E-lambda
c                  functions
c       fxi    = the ionic strength (the 2nd-order electrostatic
c                  moment function I)
c       narn1  = start of species range for aqueous solution
c       narn2  = end of species range for aqueous solution
c       zchar  = array of charges
c
c     Principal output:
c
c       elsumw = sum: SUM(ij) [ E-lambda(ij) + I*E-lambda'(ij) ]*mi*mj
c       elsums = sum: SUM(ij) E-lambda'(ij)*mi*mj
c       elsump = sum: SUM(ij) E-lambda''(ij)*mi*mj
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nazpmx,nstmax
c
      integer narn1,narn2
c
      real*8 conc(nstmax),delam(2,nazpmx,nazpmx),elam(nazpmx,nazpmx),
     $ zchar(nstmax)
      real*8 elsump,elsums,elsumw,fxi
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ijz,iz,jz,nsi,nsj
c
      real*8 cij,el,elp,elpp,zi,zj
c
c-----------------------------------------------------------------------
c
      elsumw = 0.
      elsums = 0.
      elsump = 0.
c
      do nsi = narn1,narn2
        zi = zchar(nsi)
        iz = nint(abs(zi))
        if (iz .ne. 0) then
          do nsj = narn1,narn2
            if (nsi .ne. nsj) then
              zj = zchar(nsj)
              jz = nint(abs(zj))
              if (jz .ne. 0) then
                ijz = nint(zchar(nsi)*zchar(nsj))
                if ((ijz) .gt. 0) then
                  el = elam(iz,jz)
                  elp = delam(1,iz,jz)
                  elpp = delam(2,iz,jz)
                  cij = conc(nsi)*conc(nsj)
                  elsumw = elsumw + (el + fxi*elp)*cij
                  elsums = elsums + elp*cij
                  elsump = elsump + elpp*cij
                endif
              endif
            endif
          enddo
        endif
      enddo
c
      end


!*******************************************************************************
!>  @file limiter_iso_T.f
!>  @brief Contains module @ref limiter_iso_T
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  Defines the base class of the type @ref limiter_iso.
!*******************************************************************************
      MODULE limiter_iso_T

      USE stel_kinds, only : rprec, cprec
      USE v3_utilities
      USE limiter

      IMPLICIT NONE

!*******************************************************************************
!  DERIVED-TYPE DECLARATIONS
!  1) extcurz base class
!
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  Base class representing a limiter_iso function.
!>
!>  1) Limiter iso: limiter_iso
!>  Contains the data to define a scalar function of position, so that the
!>  iso-contour f=0 of the function corresponds to a geometric limit to the
!>  plasma. Also contains data to specify the minimum number poloidal points on
!>  the s=1 surface to use, and the toroidal planes on which to s=1 surface will
!>  be evaluated
!>
!>  Second attempt:
!>
!>  e = SUM_over_i(0,4)_j(0,4) [arz(i,j) (r - rc)^i (z - zc)^j]
!>  f = e / |grad(e)|
!>
!>  - @note
!>  1. For now, axisymmetric
!>  2. Easy to put in circles, ellipses, and planes
!>  3. Function f is approximately distance.
!-------------------------------------------------------------------------------
      TYPE, EXTENDS(limiter_class) :: limiter_iso_class
!>  Coefficients for the iso function.
         REAL (rprec), DIMENSION(0:4,0:4)   :: arz
!>  R offset for function.
         REAL (rprec)                       :: rc
!>  Z offset for function.
         REAL (rprec)                       :: zc
!>  Minimum number of poloidal angles for s=1 surface.
         INTEGER                            :: numin
      CONTAINS
         PROCEDURE                          ::                                 &
     &      get_max_fval => limiter_iso_get_max_fval
         PROCEDURE                          ::                                 &
     &      get_type => limiter_iso_get_type
         PROCEDURE                          ::                                 &
     &      get_value => limiter_iso_get_value
         FINAL                              :: limiter_iso_destruct
      END TYPE

!*******************************************************************************
!  INTERFACE BLOCKS
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  Interface for iso contour limiter constructor.
!-------------------------------------------------------------------------------
      INTERFACE limiter_iso_class
         MODULE PROCEDURE limiter_iso_construct
      END INTERFACE

      CONTAINS
!*******************************************************************************
!  CONSTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Construct a limiter iso function.
!>
!>  Allocates memory and initializes a @ref limiter_iso object.
!>
!>  @param[in] arz   Coefficients for the iso function.
!>  @param[in] rc    R offset for function.
!>  @param[in] zc    Z offset for function.
!>  @param[in] numin Minimum number of poloidal angles for s=1 surface.
!>  @param[in] vgrid Values of toroidal angle at which to compute s=1 surface.
!>  @param[in] on_edge     Specifies if the edge should touch the limiter or
!>                         not. If true, the reconstruction tries to have the
!>                         limiter touch the limiter. If false, the edge will
!>                         only just fall inside the limiter.
!>  @returns A pointer to a constructed @ref limiter_iso object.
!-------------------------------------------------------------------------------
      FUNCTION limiter_iso_construct(arz, rc, zc, numin, vgrid, on_edge)

      IMPLICIT NONE

!  Declare Arguments
      CLASS (limiter_iso_class), POINTER :: limiter_iso_construct
      REAL (rprec), DIMENSION(0:4,0:4), INTENT(in) :: arz
      REAL (rprec), INTENT(in)                     :: rc
      REAL (rprec), INTENT(in)                     :: zc
      INTEGER, INTENT(in)                          :: numin
      REAL (rprec), DIMENSION(:), INTENT(in)       :: vgrid
      LOGICAL, INTENT(in)                          :: on_edge

!  local variables
      REAL (rprec)                                 :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

!  First, destroy this
      ALLOCATE(limiter_iso_construct)

      limiter_iso_construct%arz = arz
      limiter_iso_construct%rc = rc
      limiter_iso_construct%zc = zc
      limiter_iso_construct%numin = numin
      limiter_iso_construct%on_edge = on_edge

      ALLOCATE(limiter_iso_construct%phi(SIZE(vgrid)))
      limiter_iso_construct%phi = vgrid

      CALL profiler_set_stop_time('limiter_iso_construct', start_time)

      END FUNCTION

!*******************************************************************************
!  DESTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Deconstruct a @ref limiter_iso object.
!>
!>  Deallocates memory and uninitializes a @ref limiter_iso object.
!>
!>  @param[inout] this A @ref limiter_iso instance.
!-------------------------------------------------------------------------------
      SUBROUTINE limiter_iso_destruct(this)

      IMPLICIT NONE

!  Declare Arguments
      TYPE (limiter_iso_class), INTENT(inout) :: this

!  Start of executable code

!  Get rid of all components
      this%arz = 0.0
      this%rc = 0.0
      this%zc = 0.0
      this%numin = 0

      END SUBROUTINE

!*******************************************************************************
!  GETTER SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Calculates the maximum value of the iso function.
!>
!>  @param[in]  this      A @ref limiter_class instance.
!>  @param[in]  num_theta Number of points in the theta direction.
!>  @param[in]  phi_index Current phi index.
!>  @param[in]  r         R positions of the last closed flux surface.
!>  @param[in]  z         Z positions of the last closed flux surface.
!>  @param[out] rphiz_at_max R, Phi, Z position of the maximum function.
!>  @returns The maximum value of the iso function.
!-------------------------------------------------------------------------------
      FUNCTION limiter_iso_get_max_fval(this, num_theta, phi_index,            &
     &                                  r, z, rphiz_at_max)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec) :: limiter_iso_get_max_fval
      CLASS (limiter_iso_class), INTENT(in)   :: this
         INTEGER, INTENT(in)                  :: num_theta
      INTEGER, INTENT(in)                     :: phi_index
      REAL (rprec), DIMENSION(:), INTENT(in)  :: r
      REAL (rprec), DIMENSION(:), INTENT(in)  :: z
      REAL (rprec), DIMENSION(3), INTENT(out) :: rphiz_at_max

!  local variables
      INTEGER                                 :: theta_index
      REAL (rprec)                            :: fval
      REAL (rprec)                            :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      limiter_iso_get_max_fval = -1.0E10
      rphiz_at_max = 0.0

      DO theta_index = 1, num_theta
         fval = this%get_value(r(theta_index), z(theta_index))

         IF (fval .gt. limiter_iso_get_max_fval) THEN
            limiter_iso_get_max_fval = fval
            rphiz_at_max = (/ r(theta_index), this%phi(phi_index),             &
     &                        z(theta_index) /)
         END IF
      END DO

      CALL profiler_set_stop_time('limiter_iso_get_max_fval',                  &
     &                            start_time)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Computes the iso value at an r, phi, z position.
!>
!>  Limiter iso function is computed as
!>
!>  e = SUM_over_i(0,4)_j(0,4) [arz(i,j) (r - rc)^i (z - zc)^j]
!>  f = e / |grad(e)|
!>
!>
!>  @param[in] this    A @ref limiter_iso instance.
!>  @param[in] rpz_arg The r point to evaluate at.
!>  @param[in] rpz_arg The z point to evaluate at.
!>  @returns The value of iso function at the r, phi, z point.
!-------------------------------------------------------------------------------
      FUNCTION limiter_iso_get_value(this, r, z)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec)                           :: limiter_iso_get_value
      CLASS (limiter_iso_class), INTENT(in)  :: this
      REAL (rprec), INTENT(in)               :: r
      REAL (rprec), INTENT(in)               :: z

!  local variables
      REAL (rprec)                           :: e
      REAL (rprec)                           :: er
      REAL (rprec)                           :: ez
      REAL (rprec)                           :: grad_e
      INTEGER                                :: i
      INTEGER                                :: j
      REAL (rprec)                           :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

!  Compute function
      e = 0.0
      DO j = 0, 4
         DO i = 0, 4
            e = e                                                              &
     &        + this%arz(i,j)*((r - this%rc)**i)*((z - this%zc)**j)
         END DO
      END DO

!  Compute de/dr
      er = 0.0
      DO j = 0, 4
         DO i = 1, 4
            er = er                                                            &
     &         + this%arz(i,j)*i*((r - this%rc)**(i-1)) *                      &
     &           ((z - this%zc)**j)
         END DO
      END DO

!  Compute de/dz
      ez = 0.0
      DO j = 1, 4
         DO i = 0, 4
            ez = ez                                                            &
     &          + this%arz(i,j)*j*((r - this%rc)**i) *                         &
     &            ((z - this%zc)**(j - 1))
         END DO
      END DO

!  Avoid divide by zero errors.
      grad_e = MAX(1.E-12, SQRT(er*er + ez*ez))

      limiter_iso_get_value = e/grad_e

      CALL profiler_set_stop_time('limiter_iso_get_value', start_time)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Gets a discription of the limiter iso type.
!>
!>  Returns a description of the limiter type for use when writting output files.
!>
!>  @param[in] this A @ref limiter_iso_class instance.
!>  @returns A string describing the limiter type.
!-------------------------------------------------------------------------------
      FUNCTION limiter_iso_get_type(this)
      USE data_parameters

      IMPLICIT NONE

!  Declare Arguments
      CHARACTER (len=data_name_length) :: limiter_iso_get_type
      CLASS (limiter_iso_class), INTENT(in) :: this

!  local variables
      REAL (rprec)                          :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      limiter_iso_get_type =                                                   &
     &   TRIM(this%limiter_class%get_type()) // 'iso'

      CALL profiler_set_stop_time('limiter_iso_get_type', start_time)

      END FUNCTION

      END MODULE


MODULE UtilitiesModule_NuclearEOS

  USE KindModule, ONLY: &
    DP

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: ComputeFVEC
  PUBLIC :: ComputeFJAC

CONTAINS

  SUBROUTINE ComputeFVEC &
               ( D_R, V_R, P_R, E_R, Y_R, D_L, V_L, P_L, E_L, Y_L, V_Sh, FVEC )

    REAL(DP),               INTENT(in)  :: D_R, V_R, P_R, E_R, Y_R
    REAL(DP),               INTENT(in)  :: D_L, V_L, P_L, E_L, Y_L, V_Sh
    REAL(DP), DIMENSION(4), INTENT(out) :: FVEC

    FVEC(1) = D_L * ( V_Sh - V_L ) - V_Sh * D_R
    FVEC(2) = P_L - V_L * V_Sh * D_R - P_R
    FVEC(3) = E_L + 0.5_DP * V_L**2 - P_L * V_L / ( V_Sh * D_R ) - E_R
    FVEC(4) = Y_L - Y_R

  END SUBROUTINE ComputeFVEC

  SUBROUTINE ComputeFJAC &
               ( D_R, V_R, P_R, E_R, Y_R, D_L, V_L, P_L, E_L, Y_L, &
                 dPdD, dPdT, dPdY, dEdD, dEdT, dEdY, V_Sh, FJAC )

    REAL(DP),                 INTENT(in)  :: D_R, V_R, P_R, E_R, Y_R
    REAL(DP),                 INTENT(in)  :: D_L, V_L, P_L, E_L, Y_L, V_Sh
    REAL(DP),                 INTENT(in)  :: dPdD, dPdT, dPdY
    REAL(DP),                 INTENT(in)  :: dEdD, dEdT, dEdY
    REAL(DP), DIMENSION(4,4), INTENT(out) :: FJAC

    FJAC(1,1) = ( V_Sh - V_L )
    FJAC(1,2) = - D_L
    FJAC(1,3) = 0.0_DP
    FJAC(1,4) = 0.0_DP

    FJAC(2,1) = dPdD
    FJAC(2,2) = - V_Sh * D_R
    FJAC(2,3) = dPdT
    FJAC(2,4) = dPdY

    FJAC(3,1) = dEdD - dPdD * V_L / ( V_Sh * D_R )
    FJAC(3,2) = V_L - P_L / ( V_Sh * D_R )
    FJAC(3,3) = dEdT - dPdT * V_L / ( V_Sh * D_R )
    FJAC(3,4) = dEdY - dPdY * V_L / ( V_Sh * D_R )

    FJAC(4,1) = 0.0_DP
    FJAC(4,2) = 0.0_DP
    FJAC(4,3) = 0.0_DP
    FJAC(4,4) = 1.0_DP

  END SUBROUTINE ComputeFJAC

END MODULE UtilitiesModule_NuclearEOS


      subroutine fpgivs(piv,ww,cos,sin)
c  subroutine fpgivs calculates the parameters of a givens
c  transformation .
c  ..
c  ..scalar arguments..
      real piv,ww,cos,sin
c  ..local scalars..
      real dd,one,store
c  ..function references..
      real abs,sqrt
c  ..
      one = 0.1e+01
      store = abs(piv)
      if(store.ge.ww) dd = store*sqrt(one+(ww/piv)**2)
      if(store.lt.ww) dd = ww*sqrt(one+(piv/ww)**2)
      cos = ww/dd
      sin = piv/dd
      ww = dd
      return
      end


! Module providing geometry-related routines for AGN feedback.
!
! Paul Ricker (2/2013)

module agn_geometry

    use amrex_fort_module, only : rt => amrex_real
    use bl_constants_module, only: M_PI

!==============================================================================

implicit none

public

! Constants for geometric shapes

integer, parameter :: INSIDE = 0, STRADDLES = 1, OUTSIDE = 2

contains

!------------------------------------------------------------------------------

! loc_sphere: For a Cartesian zone with given left and right coordinate values,
!             determine whether it lies entirely inside, entirely outside, or
!             partially inside and outside a given sphere.
!
! arguments: xl, yl, zl             Left-face coordinates of zone relative to
!                                   sphere's center
!            xr, yr, zr             Right-face coordinates of zone relative to
!                                   sphere's center
!            params(1)              Parameter array containing radius of sphere

integer function loc_sphere(xl, xr, yl, yr, zl, zr, R)

real(rt), intent(in) :: xl, xr, yl, yr, zl, zr, R

real(rt)             :: rl2, rr2, R2

R2  = R**2
rl2 = xl**2 + yl**2 + zl**2
rr2 = xr**2 + yr**2 + zr**2

if (rr2 <= R2) then
  loc_sphere = INSIDE
else if (rl2 > R2) then
  loc_sphere = OUTSIDE
else
  loc_sphere = STRADDLES
endif

return
end function loc_sphere

!------------------------------------------------------------------------------

! loc_cylinder: For a Cartesian zone with given left and right coordinate
!               values, determine whether it lies entirely inside, entirely
!               outside, or partially inside and outside a given cylinder.
!
! arguments: xl, yl, zl             Left-face coordinates of zone relative to
!                                   cylinder's origin point
!            xr, yr, zr             Right-face coordinates of zone relative to
!                                   cylinder's origin point
!            params(5)              Parameter array containing radius, height,
!                                   and orientation direction cosines of
!                                   cylinder

integer function loc_cylinder(xl, xr, yl, yr, zl, zr, R, h, nxc, nyc, nzc)

real(rt), intent(in) :: xl, xr, yl, yr, zl, zr
real(rt), intent(in) :: R, h, nxc, nyc, nzc

real(rt)             :: R2, xldotn, xrdotn, rl2, rr2
real(rt)             :: xlproj, xrproj, ylproj, yrproj, zlproj, zrproj

R2  = R**2

xldotn = xl*nxc + yl*nyc + zl*nzc
xrdotn = xr*nxc + yr*nyc + zr*nzc

xlproj = xl - xldotn*nxc
xrproj = xr - xrdotn*nxc
ylproj = yl - xldotn*nyc
yrproj = yr - xrdotn*nyc
zlproj = zl - xldotn*nzc
zrproj = zr - xrdotn*nzc

rl2 = xlproj**2 + ylproj**2 + zlproj**2
rr2 = xrproj**2 + yrproj**2 + zrproj**2

if ((xldotn >= 0.) .and. (xrdotn <= h) .and. (rr2 <= R2)) then
  loc_cylinder = INSIDE
else if ((xrdotn < 0.) .or. (xldotn > h) .or. (rl2 > R2)) then
  loc_cylinder = OUTSIDE
else
  loc_cylinder = STRADDLES
endif

return
end function loc_cylinder

!------------------------------------------------------------------------------

! weight_uniform: A uniform weighting function.
!
! arguments: x, y, z            Coordinates of sample point (ignored)
!            params(:)          Weighting function parameters (ignored)

real(rt) function weight_uniform(x, y, z, params)

real(rt), intent(in) :: x, y, z, params(:)

weight_uniform = 1.

return
end function weight_uniform

!------------------------------------------------------------------------------

! weight_cattaneo: Cattaneo & Teyssier weighting function.
!
! arguments: x, y, z            Coordinates of sample point
!            params(:)          Weighting function parameters: R, h, nx, ny, nz, rscale

real(rt) function weight_cattaneo(x, y, z, R, height, nx, ny, nz, rscale)

real(rt), intent(in) :: x, y, z, R, height, nx, ny, nz, rscale

real(rt)             :: xdotn, xproj, yproj, zproj, r2
real(rt)             :: vol_cylinder

xdotn = x*nx + y*ny + z*nz
xproj = x - xdotn*nx
yproj = y - xdotn*ny
zproj = z - xdotn*nz
r2    = xproj**2 + yproj**2 + zproj**2

vol_cylinder = M_PI * R**2 * height

if ((xdotn >= 0.) .and. (xdotn <= height) .and. (r2 <= R**2)) then
  weight_cattaneo = dexp(-r2/(2*rscale**2)) * &
                    xdotn/height**2 / (2*M_PI*rscale**2) /(1.d0-dexp(-0.5*(R/rscale**2))) * &
                    vol_cylinder
else
  weight_cattaneo = 0.
endif

return
end function weight_cattaneo

!==============================================================================

end module agn_geometry


C File: arrays-basic-07.f
C Illustrates: transposition of a 2-D matrix

      program main
      implicit none

      integer, dimension(3,5) :: A
      integer, dimension(5,3) :: B
      integer :: i, j

C     Initialize matrix A
      do i = 1,3
          do j = 1,5
              A(i,j) = (i*j)+(i+j)
          end do
      end do

C     Transpose A into B
      do i = 1,3
          do j = 1,5
              B(j,i) = A(i,1)
          end do
      end do

      stop
      end program main


	program matriz_un_medio

	implicit none

	real,allocatable,dimension(:,:)::mat
	integer:: fila,colum,fila2,colum2,i

	Write(*,*) "Ingrese las dimenciones de la matriz"
	Write(*,*) "Filas"
	read(*,*) fila
	Write(*,*) "Columnas"
	read(*,*) colum

	allocate(mat(fila,colum))

	write(*,*) "Ingrese los elementos de la matriz"

	 fila2=1
	 colum2=1

	 do while(fila2<=fila)

		do while(fila2<=fila.and.colum2<=colum)

	Write(*,*)"Ingrese el elemento de la matriz",fila2,",",colum2

		read(*,*)mat(fila2,colum2)
		colum2=colum2+1
		enddo

		fila2=fila2+1
		colum2=1

	  enddo

	Write(*,*)"La matriz ingresada fue :"

	do i=1,fila,1

	write(*,*) mat(i,:)
	enddo

!-----------------------------------------
	  deallocate(mat)
	  pause

	  end program


! { dg-do compile }
! { dg-options "-std=f2008" }
!
! PR fortran/36158 - Transformational BESSEL_JN/YN
! PR fortran/33197 - F2008 math functions
!
implicit none
! OK, elemental function:
 print *, bessel_yn(1, [1.0, 2.0])
 print *, bessel_yn([1, 2], 2.0)

! Wrong, transformational function:
! Does not pass check.c -- thus regarded as wrong generic function
! and thus rejected with a slightly misleading error message
 print *, bessel_yn(1, 2, [2.0, 3.0]) ! { dg-error "Too many arguments" }

! Wrong in F2008: Negative argument, ok as GNU extension
 print *, bessel_yn(-1, 3.0) ! { dg-error "Extension: Negative argument N " }

! Wrong in F2008: Negative argument -- and no need for a GNU extension
! Does not pass check.c -- thus regarded as wrong generic function
! and thus rejected with a slightly misleading error message
 print *, bessel_yn(-1, 2, 3.0) ! { dg-error "Too many arguments" }
end


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE SFT
      IMPLICIT NONE
C
C Purpose: Singleton Fast Forward fourier transform
C
      INCLUDE 'COMMON.FOR'
C
C Calls   9: APLOT  , DAWRT  , FILL   , GETCHN , GETHDR
C            GETXAX , OPNFIL , OUTFIL , SFT1D
C Called by: OTOKO
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL         DELTA
      INTEGER      ICLO,JOP,IRC,IFRAME,IHFMAX,IFRMAX,IMEM,NCHANX
      INTEGER      KREC,ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC,MID
      INTEGER      NCHAN,ICH1,ICH2,NFRAME,I,J,K
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM,OFNAM,PFNAM,XFNAM
C
C ICLO   : Close file indicator
C JOP    : Open file indicator
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C KREC   : Output file record
C ISPEC  : Frame nos. part of filename
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C OFNAM  : Modulus output header filename
C PFNAM  : Phase output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NCHANX : Nos. of points in x-axis
C MID    : Midpoint of spectrum
C DELTA  : x-axis increment
C
      DATA  IMEM/1/
C
C-----------------------------------------------------------------------
      WRITE (IPRINT,*) 'X-axis'
      CALL GETXAX (NCHANX,IRC)
      IF (IRC.NE.0) GOTO 999
10    ICLO=0
      JOP=0
      KREC=0
C
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     1             ILFR,IFINC,IHFMAX,IFRMAX,NCHAN,IRC)
      IF (IRC.NE.0) GOTO 999
C
      IFRAME=IHFMAX+IFRMAX-1
      CALL GETCHN (ITERM,IPRINT,NCHAN,ICH1,ICH2,IRC)
      IF (IRC.NE.0) GOTO 10
      DO 40 I=1,IHFMAX
C
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NCHAN,NFRAME,IRC)
         IF (IRC.EQ.0) THEN
C
            ISPEC=ISPEC+INCR
            DO 30 J=1,IFRMAX
               READ (JUNIT,REC=IFFR) (SP1(K),K=1,NCHAN)
               IFFR=IFFR+IFINC
               KREC=KREC+1
C
               CALL FILL (SP3,4096,0.0)
               CALL FILL (SP4,4096,0.0)
               DO 20 K=ICH1,ICH2
                  SP3(K)=SP1(K)
20             CONTINUE
C
               DO 1 K=2,NCHAN,2
                  SP3(K)=-SP3(K)
1              CONTINUE
               CALL SFT1D(SP3,SP4,NCHAN,NCHAN,NCHAN,1)
               DO 2 K=2,NCHAN,2
                  SP3(K)=-SP3(K)
                  SP4(K)=-SP4(K)
2              CONTINUE
C
               DO 25 K=1,NCHAN
                  SP1(K)=SQRT(SP3(K)*SP3(K)+SP4(K)*SP4(K))
                  IF (SP3(K).EQ.0) SP3(K)=1.0E-20
                  SP2(K)=ATAN2(SP4(K),SP3(K))
25             CONTINUE
C
               IF (IFRAME.EQ.1) CALL APLOT (ITERM,IPRINT,SP1,NCHAN)
               IF (KREC.GE.IFRAME) ICLO=1
               IF (KREC.EQ.1) THEN
                  WRITE (IPRINT,*) 'Modulus output'
                  CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 60
               ENDIF
               XFNAM=OFNAM
               CALL DAWRT (KUNIT,OFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1                     SP1,KREC,JOP,ICLO,IRC)
               IF (IRC.NE.0) GOTO 60
               IF (KREC.EQ.1) THEN
                  JOP=0
                  WRITE (IPRINT,*) 'Phase output'
                  CALL OUTFIL (ITERM,IPRINT,PFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 60
               ENDIF
               CALL DAWRT (KUNIT,PFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1                     SP2,KREC,JOP,ICLO,IRC)
               IF (IRC.NE.0) GOTO 60
30          CONTINUE
            CLOSE (UNIT=JUNIT)
         ENDIF
40    CONTINUE
C
      MID=NCHAN/2+1
      XAX(MID)=0.0
      DELTA=1/XAX(NCHAN)
      DO 50 I=MID+1,NCHAN
         XAX(I)=REAL(I-MID)*DELTA
50    CONTINUE
      DO 55 I=MID-1,1,-1
         XAX(I)=-REAL(MID-I)*DELTA
55    CONTINUE
      JOP=0
      ICLO=1
      IFRAME=1
      KREC=1
      XFNAM(10:10)='X'
      CALL DAWRT (KUNIT,XFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1            XAX,KREC,JOP,ICLO,IRC)
60    CLOSE (UNIT=JUNIT)
      GOTO 10
999   RETURN
      END


! Terrain Filter
!
! Contributed by S.J. Lin.
!
! Added to the definesurf program by G. Grant, 30 June 2000.
! Updated with latest version from S.J. by B. Eaton, 23 August 2001
!
! Notes from S.J.:
!
! "I compute the unsmoothed mean height and the variance
! exactly the same as the standard CCM utility. The only difference
! is the grid being uniformly spaced from North pole to South pole.
! The filter is applied to the mean height and the sqaure root of
! the variance (the standard deviation).
!
! For the 2x2.5 deg resolution
!
!      mlon = 144
!      mlat = 91
!
! Assuming the mean height is Z(mlon,mlat), and the standard deviation
! (the sqaure root of the variance) is SD(moln,mlat), the filter
! algorithm goes like this:
!
!       call sm2(mlon, mlat,  Z, itmax_Z,  0.25D0)
!       call sm2(mlon, mlat, SD, itmax_SD, 0.25D0)
!
! where 0.25D0 is the dimensionless filter coefficient, and
!
!       itmax_Z  = 2*mlat
!       itmax_SD = mlon
!
! [As discussed elsewhere] the above filtering is a bit too strong.
! But it is the filter I used up to now.
! I am currently testing the following setting
!
!       itmax_Z  = mlat/2
!       itmax_SD = mlon/4
! "

      subroutine sm2(im, jm, ht, itmax, c)
!
! Del-2 diffusion on the sphere
!
      implicit none

! Input:
      integer im               ! e-w dimension (eg, 144 for 2.5 deg resolution)
      integer jm               ! n-s doemsnion (eg, 91 for 2 deg resolution)
      integer itmax            ! iteration count
      real*8  c                ! filter coefficient

! Input/Output
      real*8 ht(im,jm)         ! array to be filtered

! Local
      real*8 dg(im,jm)   ! del2 of h
      real*8 cose(jm), cosp(jm), sinp(jm), sine(jm)
      real*8 dl
      real*8 dp
      real*8 fmin, fmax
      integer jm1
      integer mnk, mxk
      integer ndeg
      integer it, i, j
      real*8 s1, s2

      jm1 = jm-1

      call setrig(im, jm, dp, DL, cosp, cose, sinp, sine)

      call pmnx(ht, im, jm, fmin, fmax, mnk, mxk)
      write(6,*) 'hmax=', fmax,' at j= ',mxk
      write(6,*) 'hmin=', fmin,' at j= ',mnk

      ndeg = 60                    ! starting latitude for the monotonicity
                                   ! preserving polar filter

      call pmnx(ht,im,jm,fmin,fmax,mnk,mxk)
      write(6,*) 'hmax=', fmax,' at j= ',mxk
      write(6,*) 'hmin=', fmin,' at j= ',mnk

! Apply Monotonicity preserving polar filter
      call plft2d(im, jm, ht, 2, jm1, ndeg)
      call avgp2(ht, sine, im, jm)

      do it=1,itmax
	call del2(ht, im, jm, dg, cosp, cose, sine, DL, dp, ndeg)
        call plft2d(im, jm, dg, 2, jm1, ndeg)

	do j=1,jm
	   do i=1,im
             ht(i,j) = ht(i,j) + c*dg(i,j)
           enddo
        enddo
      enddo

! Final polar filter
      call plft2d(im, jm, ht, 2, jm1, ndeg)

      return
      end

      subroutine del2(h, im, jm, dg, cosp, cose, sine, dL, dp, ndeg)
      implicit none

! AE = 1  (unit radius)
! Input:
        integer im
        integer jm
        integer ndeg
! Input-output

	real*8 h(im,jm)
	real*8 dg(im,jm)              ! del2 of h
	real*8 cose(jm),cosp(jm)
	real*8 sine(jm)
	real*8 PI, ycrit, coszc, CD
	real*8 DL, dp

! Local
	real*8 fx(im,jm)   ! e-w fluxes
	real*8 fy(im,jm)   ! n-s fluxes
        integer i, j

	call grad(h, im, jm, fx, fy, cosp, dl, dp)

        PI = 4. * ATAN(1.)
        ycrit = float(ndeg)*PI/180.
        coszc = cos(ycrit)

 	CD = 0.25*DL*DP*coszc**2
!	CD = 0.25*DL*DP*cosp(2)**2

        do j=2,jm-1
           do i=1,im
              fx(i,j) = fx(i,j) * CD
           enddo
        enddo

        do j=2,jm
	   do i=1,im
	      fy(i,j) = fy(i,j) * CD
           enddo
        enddo

	call divg(im,jm,fx,fy,DG,cosp,cose,sine, dl, dp)

	return
	end

      subroutine divg(im, jm, fx, fy, dg, cosp, cose, sine, dl, dp)
      implicit none

      integer im
      integer jm
      real*8 fx(im,jm)   ! e-w fluxes
      real*8 fy(im,jm)   ! n-s fluxes
      real*8 DG(im,jm)   ! del2 of h
      real*8 wk(im,jm)
      real*8 cosp(jm),  cose(jm), sine(jm)
      real*8 rdx
      real*8 dl, dp, CDP, sum1, sum2
      integer i,j

	do j=2,jm-1

	rdx = 1./ (cosp(j)*DL)

           do i=1,im-1
              DG(i,j) = (fx(i+1,j) - fx(i,j)) * rdx
           enddo
              DG(im,j) = (fx(1,j) - fx(im,j)) * rdx
        enddo

	do j=2,jm
           do i=1,im
              wk(i,j) = fy(i,j) * cose(j)
           enddo
        enddo

	do j=2,jm-1
           CDP = 1./ (DP*cosp(j))
           do i=1,im
              DG(i,j) = DG(i,j) + (wk(i,j+1) - wk(i,j)) * CDP
           enddo
	enddo

! Poles;

	sum1 = wk(im, 2)
	sum2 = wk(im,jm)

	do i=1,im-1
           sum1 = sum1 + wk(i, 2)
           sum2 = sum2 + wk(i,jm)
	enddo

	sum1 =  sum1 / ( float(im)*(1.+sine(2)) )
	sum2 = -sum2 / ( float(im)*(1.+sine(2)) )

	do i=1,im
           DG(i, 1) =  sum1
           DG(i,jm) =  sum2
	enddo

	return
	end

      subroutine grad(h, im, jm, fx, fy, cosp, DL, DP)
      implicit none
      integer im
      integer jm
      real*8 h(im,jm)
      real*8 fx(im,jm)   ! e-w fluxes
      real*8 fy(im,jm)   ! n-s fluxes
      real*8 cosp(jm)
      real*8 RDP, DL, DP, rdx
      integer i, j

	RDP = 1./ DP

      do j=2,jm
         do i=1,im
            fy(i,j) = (h(i,j) - h(i,j-1)) * RDP
         enddo
      enddo

      do j=2,jm-1

	rdx = 1./ (cosp(j)*DL)
        fx(1,j) = (h(1,j) - h(im,j)) * rdx
        do i=2,im
           fx(i,j) = (h(i,j) - h(i-1,j)) * rdx
        enddo
      enddo

      return
      end

      subroutine avgp2(p, sine, im, jm)
      implicit none
      integer im, jm
      real*8 p(im,jm)
      real*8 sine(jm)
      real*8 sum1, sum2
      real*8 sum3, sum4
      real*8 rim
      integer i
      integer j
      integer jm1

      jm1 = jm-1
      rim = 1./ float(im)

      call sump2(p(1,1),p(1,jm),IM,sum1,sum2)
      sum1 = sum1*(1.+sine(2))
      sum2 = sum2*(1.+sine(2))

      call sump2(p(1,2),p(1,jm1),IM,sum3,sum4)
      sum1 = rim * ( sum1 + sum3*(sine(3)-sine(2)) ) / (1.+sine(3))
      sum2 = rim * ( sum2 + sum4*(sine(3)-sine(2)) ) / (1.+sine(3))

      do i=1,im
      P(i,  1) = sum1
      P(i,  2) = sum1
      P(i,jm1) = sum2
      P(i, jm) = sum2
      enddo
      return
      end

      subroutine sump2(p1,p2,im,s1,s2)
      implicit none
      integer im,i
      real*8 s1,s2
      real*8 p1(*),p2(*)

         s1 =  p1(im)
         s2 =  p2(im)

      do i=1,im-1
         s1 =  s1 + p1(i)
         s2 =  s2 + p2(i)
      enddo
      return
      end

      subroutine pmnx(a,nx,ny,fmin,fmax,mnk,mxk)
      implicit none
      integer nx
      integer ny
      integer mnk
      integer mxk
      real*8 a(nx,*)
      real*8 fmax, fmin, temp
      integer i,j

      fmax = a(1,1)
      fmin = a(1,1)
      mnk = 1
      mxk = 1

      do j=1,ny
        do i=1,nx
           temp = a(i,j)
           if(temp.gt.fmax) then
              fmax = temp
              mxk = j
           elseif(temp .lt. fmin) then
              fmin = temp
              mnk = j
           endif
        enddo
      enddo

      return
      end


program funcion
  implicit none

  integer :: i=5,l,m,n,p,q,o,a
  real :: r = 18.7010
  complex :: z=(2.9,1.3)

  !Casteos Reales
  !real convierte el valor entero a real
  print*, "Con real ", real (i)
  !dble convertir el valor entero a real con memoria de 8 bytes
  print*, "Con dble", dble(i)
  print*,"i", i

  !Casteos Enteros
  !int convierte a los numeros reales en enteros (numero sin
  print*, "Con INT: ", int (r)
  !int convierte a todos los numeros reales en enteros truncado
  print*, "Con NINT:", nint(r)
  print*, "r", r

  !Casteos Complejos
  !real te da parte real del numero complejo
  print*, "Parte real", real(z)
  !aimag te da la parte imaginaria del numero complejo
  print*, "Parte imaginara", aimag(z)
  !conjg te da el conjugado del numero complejo
  print*, "Conjugado", conjg(z)
  !cmplx convierte dos  numeros reales en un numero complejo
  print*, "el numero complejo formado por r,r es :"
  print*, cmplx(r,r)

  print*, "z",z

  print*, "la multiplicacion de r*i es"
  l=r*i
  print*, l

  print*, "la suma de r+z es"
  m=r+z
  print*, m

  print*, "la suma de z+l es"
  n=z+l
  print*, n

  print*, "la multipicacion de m*i es"
  q=m*i
  print*, q

  print*, "la division de q/n es"
  o=q/n
  print*, o

  print*, "la division de o/i es"
  p=o/i
  print*, p

  print*,"el resultado de la funcion es"
  a=p-(((r-i)/z)*(z*r))
  print*, a

end program


program ocean
    use mod_data
    use mpdata_adiff
    implicit none
    integer start_time, stop_time, clock_rate, clock_max
    integer ierr, myrank
    real*8 t1

! General procedure.
! *************************************************************
    write (*,*) "[INIT] Initializing data..."
    call allocate_init_data()

    write (*,*) "[INIT] Done!"
    write (*,*)

    write (*,*) "[RUN]  Start calculation..."
    call system_clock(start_time,clock_rate,clock_max)

    call mpdata_adiff_tile(LBi, UBi, LBj, UBj, MYDATA%oHz, MYDATA%Huon, MYDATA%Hvom, MYDATA%W, MYDATA%Ta, &
                         & MYDATA%Uind, MYDATA%Dn, MYDATA%Dm, MYDATA%Ua)

    call system_clock(stop_time,clock_rate,clock_max)
    t1 = real(stop_time - start_time)/real(clock_rate)

    write(*,'(a,f11.3,a)') '        Calculation time:',t1,'(s)'

    write (*,*) "[RUN]  Done!"
    write (*,*)

    !OPEN(3,FILE='UA.dat',FORM='unformatted')
    !WRITE(3)MYDATA%Ua(LBi : UBi, LBj : UBj, 1 : N)
    !CLOSE(3)

    write (*,*) "[VERIFY] Start verification."
    call verify_data()
    write (*,*) "[VERIFY] Done!"
    call deallocate_data()

end program