C Contains a subroutine call with uninitiated arg
      FUNCTION RTNEWT(FUNCD,X1,X2,XACC)
      PARAMETER (JMAX=20)
      RTNEWT=.5*(X1+X2)
      DO 11 J=1,JMAX
        CALL FUNCD(RTNEWT,F,DF)
        DX=F/DF
        RTNEWT=RTNEWT-DX
        IF((X1-RTNEWT)*(RTNEWT-X2) < 0.)PAUSE 'jumped out of brackets'
        IF(ABS(DX) < XACC) RETURN
11    CONTINUE
      PAUSE 'RTNEWT exceeding maximum iterations'
      END


! integral_types.f90 --
!     Define integer parameters that select integers of specified size
!     Used by the bmp_file module, as BMP files use single-byte and double-byte
!     integers, as well four-byte integers.
!
!     Note:
!     To make sure that the integer kinds are of the right size, a check is made
!     against the number of bits. Unfortunately MERGE() is not accepted by all
!     compilers in a constant expression. Hence resort to a purely arithmetic expression
!
!     Note on testing:
!     - Tested with different number of bits (9 for one_byte)
!     - Tested with unavailable kind (precision of 100)
!     As the arithmetic expression is fairly complex, this is needed.
!
module integral_types
    implicit none

    private

    integer, parameter         :: one_byte_ = selected_int_kind(2)
    integer, parameter, public :: one_byte  = &
        one_byte_ - (max(one_byte_,0)+1) * abs(bit_size(0_one_byte_)-8)

    integer, parameter         :: two_bytes_ = selected_int_kind(4)
    integer, parameter, public :: two_bytes  = &
        two_bytes_ - (max(two_bytes_,0)+1) * abs(bit_size(0_two_bytes_)-16)

    integer, parameter         :: four_bytes_ = selected_int_kind(8)
    integer, parameter, public :: four_bytes  = &
        four_bytes_ - (max(four_bytes_,0)+1) * abs(bit_size(0_four_bytes_)-32)

    ! If the compiler does not support any of these kinds, then it will not be possible to
    ! define variables with these kinds
    !
    ! integer(one_byte)   :: test_one_byte
    ! integer(two_bytes)  :: test_two_bytes
    ! integer(four_bytes) :: test_four_bytes
      integer(one_byte)   :: test_one_byte
      integer(two_bytes)  :: test_two_bytes
      integer(four_bytes) :: test_four_bytes
end module integral_types


 lambda x:Bot. x;
 lambda x:Bot. x x;

(\x:<a:Bool,b:Bool>. x) (<a=true> as <a:Bool>);

(\r:{x:Top->Top}. r.x r.x)
  {x=\z:Top.z, y=\z:Top.z};

OptionalNat = <none: (), some: Nat>;
func = \t:OptionalNat. case t of
    <none=_> => {1, 2, {a=0}}
  | <some=n> => {10, n, {a=10, b=iszero n}};
func (<some=3> as <some: Nat>);

a = ref 10;
b = ref {node=a, data=23} as {node: Ref Nat, data: Nat};


           program demo_dim
           use, intrinsic :: iso_fortran_env, only : real_kinds, &
           & real32, real64, real128
           implicit none
           integer :: i
           real(kind=real64) :: x
               i = dim(4, 15)
               x = dim(4.345_real64, 2.111_real64)
               print *, i
               print *, x
           end program demo_dim


program use_gsl
    use, intrinsic :: iso_c_binding
    implicit none
    interface
        subroutine gsl_sort(data, stride, n) bind(c)
            use, intrinsic :: iso_c_binding
            implicit none
            real(c_double), dimension(n) :: data
            integer(kind=c_size_t), value :: stride, n
        end subroutine gsl_sort
    end interface
    integer(kind=c_size_t), parameter :: nr_values = 10, stride = 1
    real(kind=c_double), dimension(nr_values) :: values

    call random_number(values)
    print '("original:")'
    print '(*(F25.15, /))', values
    call gsl_sort(values, stride, nr_values)
    print '("sorted:")'
    print '(*(F25.15, /))', values
end program use_gsl


module example

      implicit none

      interface method
          module procedure add_i4
          module procedure add_r4
          module procedure add_r8
      end interface

      contains

      integer(KIND=4) function add_i4(i,j)
          integer(KIND=4), intent (in) :: i, j
          add_i4=i+j
      end function add_i4

      real(KIND=4) function add_r4(a,b)
          real(KIND=4), intent (in) :: a, b
          add_r4=a+b
      end function add_r4

      real(KIND=8) function add_r8(a,b)
          real(KIND=8), intent (in) :: a, b
          add_r8=a+b
      end function add_r8

end module


SUBROUTINE mcdpl(phi,psi,dee,stress,pl)
!
! This subroutine forms the plastic stress/strain matrix
! for a Mohr-Coulomb material (phi,psi in degrees).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:),dee(:,:),phi,psi
 REAL(iwp),INTENT(OUT)::pl(:,:)
 REAL(iwp),ALLOCATABLE::dfds(:),dqds(:),ddqds(:),dfdsd(:)
 REAL(iwp)::t1,t2,t3,t4,t5,t6,t8,t10,t12,t13,t14,t15,t16,t17,t18,t19,t20, &
   t21,t22,t23,t24,t25,t26,t27,t28,t29,t30,t31,t32,t33,t34,t35,t36,t37,   &
   t38,t39,t40,t41,t42,t43,t44,t45,t46,t48,t49,t50,t51,t53,t54,t55,t56,   &
   t60,t61,t63,t64,t68,t69,t70,t71,t73,t74,t77,t79,t80,t82,t83,t84,t85,   &
   t86,t89,t92,t93,t94,t97,t98,t101,t103,t106,t110,t111,t113,t122,t129,   &
   t133,t140,t145,t152,t166,t186,t206,pm,pi,phir,snph,snth,sq3,sx,sy,sz,  &
   txy,tyz,tzx,zero=0.0_iwp,pt49=0.49_iwp,one=1.0_iwp,two=2.0_iwp,        &
   d3=3.0_iwp,d4=4.0_iwp,d6=6.0_iwp,d180=180.0_iwp,snps,psir
 REAL(iwp)::denom
 INTEGER::i,j,ih
 ih=SIZE(stress)
 ALLOCATE(dfds(ih),dqds(ih),ddqds(ih),dfdsd(ih))
 pi=ACOS(-one)
 phir=phi*pi/d180
 snph=SIN(phir)
 psir=psi*pi/d180
 snps=SIN(psir)
 sq3=SQRT(d3)
 SELECT CASE(ih)
 CASE(4)
   sx=stress(1)
   sy=stress(2)
   txy=stress(3)
   sz=stress(4)
   t3=one/d3
   t4=(sx+sy+sz)*t3
   t8=sz-t4
   t10=txy**2
   t16=(sx-sy)**2
   t18=(sy-sz)**2
   t20=(sz-sx)**2
   t25=SQRT((t16+t18+t20)/d6+t10)
   t26=t25**2
   t30=d3*sq3*((sx-t4)*(sy-t4)*t8-t8*t10)/two/t26/t25
   IF(t30>one)t30=one
   IF(t30<-one)t30=-one
   t31=ASIN(t30)
   t33=SIN(t31*t3)
   snth=-t33
   IF(ABS(snth).GT.pt49)THEN
     pm=-one
     if(snth.LT.zero)pm=one
     t2=snph/d3
     t4=(sx-sy)**2
     t6=(sy-sz)**2
     t8=(sz-sx)**2
     t10=one/d6
     t12=txy**2
     t14=SQRT((t4+t6+t8)*t10+t12)
     t17=one/t14/sq3
     t18=one/two
     t19=t17*t18
     t21=d3+pm*snph
     t23=two*sy
     t24=two*sz
     t31=two*sx
     dfds(1)=t2+t19*t21*(d4*sx-t23-t24)*t10/two
     dfds(2)=t2+t19*t21*(-t31+d4*sy-t24)*t10/two
     dfds(3)=t17*t18*t21*txy
     dfds(4)=t2+t19*t21*(-t23+d4*sz-t31)*t10/two
     t2=snps/d3
     t21=d3+pm*snps
     dqds(1)=t2+t19*t21*(d4*sx-t23-t24)*t10/two
     dqds(2)=t2+t19*t21*(-t31+d4*sy-t24)*t10/two
     dqds(3)=t17*t18*t21*txy
     dqds(4)=t2+t19*t21*(-t23+d4*sz-t31)*t10/two
   ELSE
     t1=one/d3
     t2=snph*t1
     t4=(sx-sy)**2
     t6=(sy-sz)**2
     t8=(sz-sx)**2
     t10=one/d6
     t12=txy**2
     t13=(t4+t6+t8)*t10+t12
     t14=SQRT(t13)
     t16=d3*sq3
     t18=(sx+sy+sz)*t1
     t19=sx-t18
     t20=sy-t18
     t21=t19*t20
     t22=sz-t18
     t25=t21*t22-t22*t12
     t26=one/two
     t28=t14**2
     t30=one/t28/t14
     t31=t16*t25*t26*t30
     IF(t31>one)t31=one
     IF(t31<-one)t31=-one
     t33=ASIN(t31)
     t34=t33*t1
     t35=COS(t34)
     t36=SIN(t34)
     t38=one/sq3
     t41=one/t14*(t35+t36*snph*t38)
     t43=two*sy
     t44=two*sz
     t46=(d4*sx-t43-t44)*t10
     t49=one-t1
     t53=t19*t1*t22
     t54=t21*t1
     t55=t1*t12
     t60=t16*t25
     t61=t28**2
     t64=t26/t61/t14
     t68=t16*(t49*t20*t22-t53-t54+t55)*t26*t30-d3/two*t60*t64*t46
     t70=d3**2
     t71=sq3**2
     t73=t25**2
     t74=two**2
     t77=t13**2
     t83=SQRT(one-t70*t71*t73/t74/t77/t13)
     t84=one/t83
     t85=t84*t1
     t89=t2*t38
     t94=two*sx
     t97=(-t94+d4*sy-t44)*t10
     t101=t1*t20*t22
     t111=t16*(-t101+t19*t49*t22-t54+t55)*t26*t30-d3/two*t60*t64*t97
     t129=-two*t16*t22*txy*t26*t30-d3*t60*t64*txy
     t140=(-t43+d4*sz-t94)*t10
     t152=t16*(-t101-t53+t21*t49-t49*t12)*t26*t30-d3/two*t60*t64*t140
     dfds(1)=t2+t41*t46/two+t14*(-t36*t68*t85+t35*t68*t84*t89)
     dfds(2)=t2+t41*t97/two+t14*(-t36*t111*t85+t35*t111*t84*t89)
     dfds(3)=t41*txy+t14*(-t36*t129*t85+t35*t129*t84*t89)
     dfds(4)=t2+t41*t140/two+t14*(-t36*t152*t85+t35*t152*t84*t89)
     t2=snps*t1
     t41=one/t14*(t35+t36*snps*t38)
     t89=t2*t38
     dqds(1)=t2+t41*t46/two+t14*(-t36*t68*t85+t35*t68*t84*t89)
     dqds(2)=t2+t41*t97/two+t14*(-t36*t111*t85+t35*t111*t84*t89)
     dqds(3)=t41*txy+t14*(-t36*t129*t85+t35*t129*t84*t89)
     dqds(4)=t2+t41*t140/two+t14*(-t36*t152*t85+t35*t152*t84*t89)
   END IF
 CASE(6)
   sx=stress(1)
   sy=stress(2)
   sz=stress(3)
   txy=stress(4)
   tyz=stress(5)
   tzx=stress(6)
   t3=one/d3
   t4=(sx+sy+sz)*t3
   t5=sx-t4
   t6=sy-t4
   t8=sz-t4
   t10=tyz**2
   t12=tzx**2
   t14=txy**2
   t23=(sx-sy)**2
   t25=(sy-sz)**2
   t27=(sz-sx)**2
   t32=SQRT((t23+t25+t27)/d6+t14+t10+t12)
   t33=t32**2
   t37=d3*sq3*(t5*t6*t8-t5*t10-t6*t12-t8*t14+two*txy*tyz*tzx)/two/t33/t32
   IF(t37>one)t37=one
   IF(t37<-one)t37=-one
   t38=ASIN(t37)
   t40=SIN(t38*t3)
   snth=-t40
   IF(ABS(snth).GT.pt49)THEN
     pm=-one
     IF(snth.LT.zero)pm=one
     t2=snph/d3
     t4=(sx-sy)**2
     t6=(sy-sz)**2
     t8=(sz-sx)**2
     t10=one/d6
     t12=txy**2
     t13=tyz**2
     t14=tzx**2
     t16=SQRT((t4+t6+t8)*t10+t12+t13+t14)
     t19=one/t16/sq3
     t20=one/two
     t21=t19*t20
     t23=d3+pm*snph
     t25=two*sy
     t26=two*sz
     t33=two*sx
     t48=t20*t23
     dfds(1)=t2+t21*t23*(d4*sx-t25-t26)*t10/two
     dfds(2)=t2+t21*t23*(-t33+d4*sy-t26)*t10/two
     dfds(3)=t2+t21*t23*(-t25+d4*sz-t33)*t10/two
     dfds(4)=t19*t48*txy
     dfds(5)=t19*t48*tyz
     dfds(6)=t19*t48*tzx
     t2=snps/d3
     t23=d3+pm*snps
     t48=t20*t23
     dqds(1)=t2+t21*t23*(d4*sx-t25-t26)*t10/two
     dqds(2)=t2+t21*t23*(-t33+d4*sy-t26)*t10/two
     dqds(3)=t2+t21*t23*(-t25+d4*sz-t33)*t10/two
     dqds(4)=t19*t48*txy
     dqds(5)=t19*t48*tyz
     dqds(6)=t19*t48*tzx
   ELSE
     t1=one/d3
     t2=snph*t1
     t4=(sx-sy)**2
     t6=(sy-sz)**2
     t8=(sz-sx)**2
     t10=one/d6
     t12=txy**2
     t13=tyz**2
     t14=tzx**2
     t15=(t4+t6+t8)*t10+t12+t13+t14
     t16=SQRT(t15)
     t18=d3*sq3
     t20=(sx+sy+sz)*t1
     t21=sx-t20
     t22=sy-t20
     t23=t21*t22
     t24=sz-t20
     t29=two*txy
     t32=t23*t24-t21*t13-t22*t14-t24*t12+t29*tyz*tzx
     t33=one/two
     t35=t16**2
     t37=one/t35/t16
     t39=t18*t32*t33*t37
     IF(t39>one)t39=one
     IF(t39<-one)t39=-one
     t40=ASIN(t39)
     t41=t40*t1
     t42=COS(t41)
     t43=SIN(t41)
     t45=one/sq3
     t48=one/t16*(t42+t43*snph*t45)
     t50=two*sy
     t51=two*sz
     t53=(d4*sx-t50-t51)*t10
     t56=one-t1
     t60=t21*t1*t24
     t61=t23*t1
     t63=t1*t14
     t64=t1*t12
     t69=t18*t32
     t70=t35**2
     t73=t33/t70/t16
     t77=t18*(t56*t22*t24-t60-t61-t56*t13+t63+t64)*t33*t37-               &
       d3/two*t69*t73*t53
     t79=d3**2
     t80=sq3**2
     t82=t32**2
     t83=two**2
     t86=t15**2
     t92=SQRT(one-t79*t80*t82/t83/t86/t15)
     t93=one/t92
     t94=t93*t1
     t98=t2*t45
     t103=two*sx
     t106=(-t103+d4*sy-t51)*t10
     t110=t1*t22*t24
     t113=t1*t13
     t122=t18*(-t110+t21*t56*t24-t61+t113-t56*t14+t64)*t33*t37-           &
       d3/two*t69*t73*t106
     t133=(-t50+d4*sz-t103)*t10
     t145=t18*(-t110-t60+t23*t56+t113+t63-t56*t12)*t33*t37-               &
       d3/two*t69*t73*t133
     t166=t18*(-two*t24*txy+two*tyz*tzx)*t33*t37-d3*t69*t73*txy
     t186=t18*(-two*t21*tyz+t29*tzx)*t33*t37-d3*t69*t73*tyz
     t206=t18*(-two*t22*tzx+t29*tyz)*t33*t37-d3*t69*t73*tzx
     dfds(1)=t2+t48*t53/two+t16*(-t43*t77*t94+t42*t77*t93*t98)
     dfds(2)=t2+t48*t106/two+t16*(-t43*t122*t94+t42*t122*t93*t98)
     dfds(3)=t2+t48*t133/two+t16*(-t43*t145*t94+t42*t145*t93*t98)
     dfds(4)=t48*txy+t16*(-t43*t166*t94+t42*t166*t93*t98)
     dfds(5)=t48*tyz+t16*(-t43*t186*t94+t42*t186*t93*t98)
     dfds(6)=t48*tzx+t16*(-t43*t206*t94+t42*t206*t93*t98)
     t2=snps*t1
     t48=one/t16*(t42+t43*snps*t45)
     t98=t2*t45
     dqds(1)=t2+t48*t53/two+t16*(-t43*t77*t94+t42*t77*t93*t98)
     dqds(2)=t2+t48*t106/two+t16*(-t43*t122*t94+t42*t122*t93*t98)
     dqds(3)=t2+t48*t133/two+t16*(-t43*t145*t94+t42*t145*t93*t98)
     dqds(4)=t48*txy+t16*(-t43*t166*t94+t42*t166*t93*t98)
     dqds(5)=t48*tyz+t16*(-t43*t186*t94+t42*t186*t93*t98)
     dqds(6)=t48*tzx+t16*(-t43*t206*t94+t42*t206*t93*t98)
   END IF
 END SELECT
 ddqds=MATMUL(dee,dqds)
 dfdsd=MATMUL(dee,dfds)
 denom=DOT_PRODUCT(dfdsd,dqds)
 DO i=1,ih
   DO j=1,ih
     pl(i,j)=ddqds(i)*dfdsd(j)/denom
   END DO
 END DO
 DEALLOCATE(dfds,dqds,ddqds,dfdsd)
RETURN
END SUBROUTINE mcdpl


! Create the psi term, where psi = D_0 p_0/Dt

module make_psi_module

  use bl_types
  implicit none
  private
  public :: make_psi_planar, make_psi_spherical

contains

  subroutine make_psi_planar(etarho_cc,psi)

    use bl_constants_module
    use geometry, only: base_cutoff_density_coord, r_start_coord, r_end_coord, &
         numdisjointchunks, nlevs_radial
    use probin_module, only: grav_const
    use restrict_base_module

    real(kind=dp_t), intent(in   ) :: etarho_cc(:,0:)
    real(kind=dp_t), intent(inout) ::       psi(:,0:)

    ! Local variables
    integer         :: r,i,n

    psi = ZERO

    do n=1,nlevs_radial
       do i=1,numdisjointchunks(n)
          do r = r_start_coord(n,i), r_end_coord(n,i)
             if (r .lt. base_cutoff_density_coord(n)) then
                psi(n,r) = etarho_cc(n,r) * abs(grav_const)
             end if
          end do
       end do
    end do

    call restrict_base(psi,.true.)
    call fill_ghost_base(psi,.true.)

  end subroutine make_psi_planar

  subroutine make_psi_spherical(psi,w0,gamma1bar,p0_avg,Sbar_in)

    use bl_constants_module
    use geometry, only: dr, r_cc_loc, r_edge_loc, base_cutoff_density_coord

    real(kind=dp_t), intent(inout) ::       psi(:,0:)
    real(kind=dp_t), intent(in   ) ::        w0(:,0:)
    real(kind=dp_t), intent(in   ) :: gamma1bar(:,0:)
    real(kind=dp_t), intent(in   ) ::    p0_avg(:,0:)
    real(kind=dp_t), intent(in   ) ::   Sbar_in(:,0:)

    ! local variables
    integer :: r
    real(kind=dp_t) :: div_w0_sph

    psi = ZERO

    !$OMP PARALLEL DO PRIVATE(r,div_w0_sph)
    do r=0,base_cutoff_density_coord(1)-1

       div_w0_sph = one/(r_cc_loc(1,r)**2)* &
            (r_edge_loc(1,r+1)**2 * w0(1,r+1) - &
             r_edge_loc(1,r  )**2 * w0(1,r  )) / dr(1)

       psi(1,r) = gamma1bar(1,r) * p0_avg(1,r) * (Sbar_in(1,r) - div_w0_sph)

    enddo
    !$OMP END PARALLEL DO

  end subroutine make_psi_spherical

end module make_psi_module


************************************************************************
*
*     Subroutine DSLVMU                               Called by: DHUMIT
*
*     multiplies symmetric matrix times vector, given the lower
*     triangle of the matrix
*
C  ***  SET  Y = S * X,  S = N X N SYMMETRIC MATRIX.
C  ***  LOWER TRIANGLE OF  S  STORED ROWWISE.
*
************************************************************************
      SUBROUTINE DSLVMU(NP,Y,S,X)
*
*     subroutine arguments
*
      INTEGER*4 NP
      DOUBLE PRECISION S(*),X(*),Y(*)
*
*     local vars
*
      INTEGER*4 I,J,K
*
*     function declaration
*
      DOUBLE PRECISION DDOT
*
*
*
      J = 1
      DO 10 I = 1,NP+1
         Y(I) = DDOT(I,S(J),X)
         J = J + I
 10   CONTINUE

      J = 1
      DO 40 I = 2,NP+1
         J = J + 1
         DO 30 K = 1,I-1
            Y(K) = Y(K) + S(J)*X(I)
            J = J + 1
 30      CONTINUE
 40   CONTINUE

      RETURN
      END


      program run_simulation
        use, intrinsic :: iso_fortran_env, only : REAL64, INT16, INT32, INT64, stdout=>output_unit

        use io, only : NDataFiles, read_program_input, clean_up_io, paramformat, padr
        use physics, only : p, init_physics, NCollProc, dt, tfin, n
        use interpolation, only : nri, init_interpolation, interpolate, clean_up_interp
        use random, only : seed_rand_0
        use single_particle, only : onepart, e0
        use eedf, only : init_eedfbins, Ntimes, calculate_totals, print_eedf
        use ratecoeffs, only : calculate_ratecoeffs_evolution, print_ratecoeffs, clean_up_ratecoeffs
        use populations, only : calculate_pops, print_pops, clean_up_pops, init_pops, Npops, neexpr

        implicit none

        ! VARIABLE DECLARATIONS
        integer(INT64) Nruns, i
        integer :: clock_start, clock_end, clock_rate
        !

        ! INITIALIZATION

          ! start timer
          call system_clock(count_rate=clock_rate)
          call system_clock(count=clock_start)

          ! get input from stdin
          call read_program_input(Nruns, tfin, dt, e0, p, Npops, neexpr)

          ! initialize cross-section interpolations and population ODE's
          call init_interpolation()

          NCollProc = NDataFiles

          do i=1,NCollProc
            call interpolate(i)
          end do

          call init_pops()

          ! clean up allocated memory
          call clean_up_io()

          ! allocate space for histogram, initialize to zero
          Ntimes = int(ceiling(tfin/dt))
          call init_eedfbins(e0)

          ! initialize physics module
          call init_physics()

          write(stdout, paramformat) padr("Initial energy", 30), e0, padr("eV", 5)
          write(stdout, paramformat) padr("End time", 30), tfin*1e9, padr("ns", 5)
          write(stdout, paramformat) padr("Time step", 30), dt*1e9, padr("ns", 5)
          write(stdout, paramformat) padr("Gas pressure", 30) , p, padr("Torr", 5)
          write(stdout, paramformat) padr("Gas density", 30) , n*1e-6, padr("cm^-3", 5)
          write(stdout, '((A),(A))') padr("Electron density expression", 30), neexpr

          ! seed pseudo-random number generator
          call seed_rand_0()

        ! SIMULATION

          ! split work on all threads
          do i=1, Nruns
            call onepart()
          end do

        ! POST PROCESSING

          ! summarize eedf
          call calculate_totals()

          call print_eedf()

          ! calculate rate coefficients
          call calculate_ratecoeffs_evolution()
          call print_ratecoeffs()

          call calculate_pops()
          call print_pops()

          call clean_up_ratecoeffs()
          call clean_up_pops()

          ! stop timer
          call system_clock(count=clock_end)
          write(stdout,paramformat) padr('It took', 30), (clock_end-clock_start)/real(clock_rate,REAL64), padr("s", 5)

        ! CLEAN UP
          !  deallocate(bins)g
          call clean_up_interp()
        end program run_simulation


      MODULE dvdrvr_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.3E  20:12:31   2/12/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      SUBROUTINE dvdrvr (IRC, IREV, N, HIEND, LIM, MBLOCK, NOC, NUME, NIV, NEIG&
         , ISELEC, CRITE, CRITC, CRITR, MAXITER, EIGVAL, BASIS, ORTHOBASIS, AB&
         , S, TEMPS, SVEC, SCRA1, ISCRA2, INCV, ICV, OLDVAL, NLOOPS, IERR)
      USE vast_kind_param,ONLY: DOUBLE
      INTEGER, INTENT(INOUT) :: IRC
      INTEGER, DIMENSION(*), INTENT(OUT) :: IREV
      INTEGER, INTENT(IN) :: N
      LOGICAL, INTENT(IN) :: HIEND
      INTEGER, INTENT(IN) :: LIM
      INTEGER :: MBLOCK
      INTEGER, INTENT(IN) :: NOC
      INTEGER, INTENT(IN) :: NUME
      INTEGER, INTENT(IN) :: NIV
      INTEGER, INTENT(IN) :: NEIG
      INTEGER, DIMENSION(NEIG) :: ISELEC
      REAL(DOUBLE) :: CRITE
      REAL(DOUBLE) :: CRITC
      REAL(DOUBLE) :: CRITR
      INTEGER, INTENT(IN) :: MAXITER
      REAL(DOUBLE), DIMENSION(LIM), INTENT(INOUT) :: EIGVAL
      REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS
      REAL(DOUBLE), DIMENSION(N*LIM + NOC*N) :: ORTHOBASIS
      REAL(DOUBLE), DIMENSION(N*LIM) :: AB
      REAL(DOUBLE), DIMENSION(LIM*(LIM + 1)/2) :: S
      REAL(DOUBLE), DIMENSION(LIM*(LIM + 1)/2) :: TEMPS
      REAL(DOUBLE), DIMENSION(LIM*LIM) :: SVEC
      REAL(DOUBLE), DIMENSION(8*LIM), INTENT(INOUT) :: SCRA1
      INTEGER, DIMENSION(5*LIM) :: ISCRA2
      INTEGER, DIMENSION(LIM), INTENT(IN) :: INCV
      INTEGER, DIMENSION(NUME + 1), INTENT(OUT) :: ICV
      REAL(DOUBLE), DIMENSION(NUME + 1), INTENT(INOUT) :: OLDVAL
      INTEGER, INTENT(INOUT) :: NLOOPS
      INTEGER, INTENT(INOUT) :: IERR
!VAST.../MPI/ MYID(IN)
!VAST...Calls: TSTSEL, SLAMCH, DCOPY, DSPEVX, OVFLOW, NEWVEC
!VAST...Calls: DSCAL, MGS_NRM, ADDS, MULTBC, DAXPY, DDOT
!...This routine performs I/O.
      END SUBROUTINE
      END INTERFACE
      END MODULE


      DOUBLE PRECISION FUNCTION psi1(xx)
C---------------------------------------------------------------------
C
C                 EVALUATION OF THE DIGAMMA FUNCTION
C
C                           -----------
C
C     PSI1(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT
C     BE COMPUTED.
C
C     THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV
C     APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY
C     CODY, STRECOK AND THACHER.
C
C---------------------------------------------------------------------
C     PSI1 WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK
C     PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI1 WAS MODIFIED BY
C     A.H. MORRIS (NSWC).
C---------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION xx
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION aug,den,dx0,piov4,sgn,upper,w,x,xmax1,xmx0,
     +                 xsmall,z
      INTEGER i,m,n,nq
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION p1(7),p2(4),q1(6),q2(4)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION spmpar
      INTEGER ipmpar
      EXTERNAL spmpar,ipmpar
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,cos,dble,dlog,dmin1,int,sin
C     ..
C     .. Data statements ..
C---------------------------------------------------------------------
C
C     PIOV4 = PI/4
C     DX0 = ZERO OF PSI1 TO EXTENDED PRECISION
C
C---------------------------------------------------------------------
C---------------------------------------------------------------------
C
C     COEFFICIENTS FOR RATIONAL APPROXIMATION OF
C     PSI1(X) / (X - X0),  0.5 .LE. X .LE. 3.0
C
C---------------------------------------------------------------------
C---------------------------------------------------------------------
C
C     COEFFICIENTS FOR RATIONAL APPROXIMATION OF
C     PSI1(X) - LN(X) + 1 / (2*X),  X .GT. 3.0
C
C---------------------------------------------------------------------
      DATA piov4/.785398163397448D0/
      DATA dx0/1.461632144968362341262659542325721325D0/
      DATA p1(1)/.895385022981970D-02/,p1(2)/.477762828042627D+01/,
     +     p1(3)/.142441585084029D+03/,p1(4)/.118645200713425D+04/,
     +     p1(5)/.363351846806499D+04/,p1(6)/.413810161269013D+04/,
     +     p1(7)/.130560269827897D+04/
      DATA q1(1)/.448452573429826D+02/,q1(2)/.520752771467162D+03/,
     +     q1(3)/.221000799247830D+04/,q1(4)/.364127349079381D+04/,
     +     q1(5)/.190831076596300D+04/,q1(6)/.691091682714533D-05/
      DATA p2(1)/-.212940445131011D+01/,p2(2)/-.701677227766759D+01/,
     +     p2(3)/-.448616543918019D+01/,p2(4)/-.648157123766197D+00/
      DATA q2(1)/.322703493791143D+02/,q2(2)/.892920700481861D+02/,
     +     q2(3)/.546117738103215D+02/,q2(4)/.777788548522962D+01/
C     ..
C     .. Executable Statements ..
C---------------------------------------------------------------------
C
C     MACHINE DEPENDENT CONSTANTS ...
C
C        XMAX1  = THE SMALLEST POSITIVE FLOATING POINT CONSTANT
C                 WITH ENTIRELY INTEGER REPRESENTATION.  ALSO USED
C                 AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE
C                 ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH
C                 PSI1 MAY BE REPRESENTED AS ALOG(X).
C
C        XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X)
C                 MAY BE REPRESENTED BY 1/X.
C
C---------------------------------------------------------------------
      xmax1 = ipmpar(3)
      xmax1 = dmin1(xmax1,1.0D0/spmpar(1))
      xsmall = 1.D-9
C---------------------------------------------------------------------
      x = xx
      aug = 0.0D0
      IF (x.GE.0.5D0) GO TO 50
C---------------------------------------------------------------------
C     X .LT. 0.5,  USE REFLECTION FORMULA
C     PSI1(1-X) = PSI1(X) + PI * COTAN(PI*X)
C---------------------------------------------------------------------
      IF (abs(x).GT.xsmall) GO TO 10
      IF (x.EQ.0.0D0) GO TO 100
C---------------------------------------------------------------------
C     0 .LT. ABS(X) .LE. XSMALL.  USE 1/X AS A SUBSTITUTE
C     FOR  PI*COTAN(PI*X)
C---------------------------------------------------------------------
      aug = -1.0D0/x
      GO TO 40
C---------------------------------------------------------------------
C     REDUCTION OF ARGUMENT FOR COTAN
C---------------------------------------------------------------------
   10 w = -x
      sgn = piov4
      IF (w.GT.0.0D0) GO TO 20
      w = -w
      sgn = -sgn
C---------------------------------------------------------------------
C     MAKE AN ERROR EXIT IF X .LE. -XMAX1
C---------------------------------------------------------------------
   20 IF (w.GE.xmax1) GO TO 100
      nq = int(w)
      w = w - dble(nq)
      nq = int(w*4.0D0)
      w = 4.0D0* (w-dble(nq)*.25D0)
C---------------------------------------------------------------------
C     W IS NOW RELATED TO THE FRACTIONAL PART OF  4.0 * X.
C     ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST
C     QUADRANT AND DETERMINE SIGN
C---------------------------------------------------------------------
      n = nq/2
      IF ((n+n).NE.nq) w = 1.0D0 - w
      z = piov4*w
      m = n/2
      IF ((m+m).NE.n) sgn = -sgn
C---------------------------------------------------------------------
C     DETERMINE FINAL VALUE FOR  -PI*COTAN(PI*X)
C---------------------------------------------------------------------
      n = (nq+1)/2
      m = n/2
      m = m + m
      IF (m.NE.n) GO TO 30
C---------------------------------------------------------------------
C     CHECK FOR SINGULARITY
C---------------------------------------------------------------------
      IF (z.EQ.0.0D0) GO TO 100
C---------------------------------------------------------------------
C     USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND
C     SIN/COS AS A SUBSTITUTE FOR TAN
C---------------------------------------------------------------------
      aug = sgn* ((cos(z)/sin(z))*4.0D0)
      GO TO 40

   30 aug = sgn* ((sin(z)/cos(z))*4.0D0)
   40 x = 1.0D0 - x
   50 IF (x.GT.3.0D0) GO TO 70
C---------------------------------------------------------------------
C     0.5 .LE. X .LE. 3.0
C---------------------------------------------------------------------
      den = x
      upper = p1(1)*x
C
      DO 60 i = 1,5
          den = (den+q1(i))*x
          upper = (upper+p1(i+1))*x
   60 CONTINUE
C
      den = (upper+p1(7))/ (den+q1(6))
      xmx0 = dble(x) - dx0
      psi1 = den*xmx0 + aug
      RETURN
C---------------------------------------------------------------------
C     IF X .GE. XMAX1, PSI1 = LN(X)
C---------------------------------------------------------------------
   70 IF (x.GE.xmax1) GO TO 90
C---------------------------------------------------------------------
C     3.0 .LT. X .LT. XMAX1
C---------------------------------------------------------------------
      w = 1.0D0/ (x*x)
      den = w
      upper = p2(1)*w
C
      DO 80 i = 1,3
          den = (den+q2(i))*w
          upper = (upper+p2(i+1))*w
   80 CONTINUE
C
      aug = upper/ (den+q2(4)) - 0.5D0/x + aug
   90 psi1 = aug + dlog(x)
      RETURN
C---------------------------------------------------------------------
C     ERROR RETURN
C---------------------------------------------------------------------
  100 psi1 = 0.0D0
      RETURN

      END


program test
  use numerics, only: dp
  use fine, only: formula, deltafunc, vegafunc, calibrate, calibrate_ts, &
                  calibrate_vol

  implicit none

  real(dp) :: r = 0.02

  real(dp) :: K(40) = [ &
     93.71,  86.03,  81.12,  77.60,  74.70,  72.16,  66.99,  61.37, &
     99.56,  98.68,  97.28,  95.88,  94.64,  93.58,  91.75,  90.25, &
    104.27, 104.63, 104.99, 105.30, 105.62, 105.93, 106.63, 107.66, &
    122.87, 123.99, 124.85, 126.59, 126.46, 127.15, 128.59, 130.46, &
    139.39, 141.02, 142.91, 144.56, 146.03, 147.36, 150.05, 153.28]

  real(dp) :: t(40) = [ &
    0.1190, 0.2381, 0.3571, 0.4762, 0.5952, 0.7143, 1.0714, 1.4286, &
    0.1190, 0.2381, 0.3571, 0.4762, 0.5952, 0.7143, 1.0714, 1.4286, &
    0.1190, 0.2381, 0.3571, 0.4762, 0.5952, 0.7143, 1.0714, 1.4286, &
    0.1190, 0.2381, 0.3571, 0.4762, 0.5952, 0.7143, 1.0714, 1.4286, &
    0.1190, 0.2381, 0.3571, 0.4762, 0.5952, 0.7143, 1.0714, 1.4286]

  call test_calibrate()
  call test_calibrate_ts()
  call test_calibrate_vol()
  call test_deltafunc()
  call test_vegafunc()

contains

  subroutine assert(condition)
    logical :: condition

    if(.not. condition) stop 1
  end subroutine assert

  subroutine test_calibrate()
    real(dp) :: s = 100
    real(dp) :: v     =  0.08
    real(dp) :: kappa =  3.0
    real(dp) :: theta =  0.1
    real(dp) :: nu    =  0.25
    real(dp) :: rho   = -0.8
    real(dp) :: prices(40), params_hat(5)

    prices = formula(t, s, v, k, r, kappa, theta, nu, rho)
    params_hat = calibrate(prices, t, k, s, r)

    call assert(abs(v     - params_hat(1)) < 0.01)
    call assert(abs(kappa - params_hat(2)) < 0.01)
    call assert(abs(theta - params_hat(3)) < 0.01)
    call assert(abs(nu    - params_hat(4)) < 0.01)
    call assert(abs(rho   - params_hat(5)) < 0.01)
  end subroutine test_calibrate

  subroutine test_calibrate_ts()
    real(dp) :: S(3) = [80, 100, 120]
    real(dp) :: v(3) = [0.08, 0.12, 0.10]
    real(dp) :: kappa =  3.0
    real(dp) :: theta =  0.1
    real(dp) :: nu    =  0.25
    real(dp) :: rho   = -0.8
    real(dp) :: prices(40, 3), params_hat(7)
    integer :: i

    do i = 1, 3
       prices(:, i) = formula(t, S(i), v(i), K, r, kappa, theta, nu, rho)
    end do

    call calibrate_ts(params_hat, prices, t, K, S, r)

    call assert(abs(v(1)  - params_hat(1)) < 0.01)
    call assert(abs(v(2)  - params_hat(2)) < 0.01)
    call assert(abs(v(3)  - params_hat(3)) < 0.01)
    call assert(abs(kappa - params_hat(4)) < 0.01)
    call assert(abs(theta - params_hat(5)) < 0.01)
    call assert(abs(nu    - params_hat(6)) < 0.01)
    call assert(abs(rho   - params_hat(7)) < 0.01)
  end subroutine test_calibrate_ts

  subroutine test_calibrate_vol()
    real(dp) :: S = 100
    real(dp) :: v     =  0.08
    real(dp) :: kappa =  3.0
    real(dp) :: theta =  0.1
    real(dp) :: nu    =  0.25
    real(dp) :: rho   = -0.8
    real(dp) :: prices(40), v_hat

    prices = formula(t, S, v, K, r, kappa, theta, nu, rho)
    v_hat = calibrate_vol(prices, t, K, S, r, kappa, theta, nu, rho)

    call assert(abs(v - v_hat) < 0.01)
  end subroutine test_calibrate_vol

  subroutine test_deltafunc()
    real(dp) :: S = 100
    real(dp) :: v     =  0.08
    real(dp) :: kappa =  3.0
    real(dp) :: theta =  0.1
    real(dp) :: nu    =  0.25
    real(dp) :: rho   = -0.8
    real(dp) :: analytic(40), finite_diff(40)
    real(dp) :: h = 0.1
    integer :: i

    analytic = deltafunc(t, S, v, K, r, kappa, theta, nu, rho)
    finite_diff = (formula(t, S + h/2, v, K, r, kappa, theta, nu, rho) &
                  -formula(t, S - h/2, v, K, r, kappa, theta, nu, rho))/h

    do i = 1, 40
      call assert(abs(finite_diff(i) - analytic(i)) < 0.00001)
    end do
  end subroutine test_deltafunc

  subroutine test_vegafunc()
    real(dp) :: S = 100
    real(dp) :: v     =  0.08
    real(dp) :: kappa =  3.0
    real(dp) :: theta =  0.1
    real(dp) :: nu    =  0.25
    real(dp) :: rho   = -0.8
    real(dp) :: analytic(40), finite_diff(40)
    real(dp) :: h = 0.0001
    integer :: i

    analytic = vegafunc(t, S, v, K, r, kappa, theta, nu, rho)
    finite_diff = (formula(t, S, v + h/2, K, r, kappa, theta, nu, rho) &
                  -formula(t, S, v - h/2, K, r, kappa, theta, nu, rho))/h

    do i = 1, 40
       call assert(abs(finite_diff(i) - analytic(i)) < 0.00001)
    end do
  end subroutine test_vegafunc

end program test


!-----------------------------------------------------------------------
!     Function:      db_midpoint
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          03/02/2012
!     Description:   This subroutine calculates the flux due to a line
!                    segment using midpoint formula.
!-----------------------------------------------------------------------
      REAL FUNCTION db_midpoint(x0,y0,z0,x1,y1,z1,cg,ldb)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE virtual_casing_mod
      USE biotsavart
      USE bsc_T
!-----------------------------------------------------------------------
!     Local Variables
!          ier            Error Flag
!          iunit          File ID Number
!-----------------------------------------------------------------------
      INTEGER, intent(in) :: CG
      real(rprec)   , intent(in) :: x0,y0,z0,x1,y1,z1
      LOGICAL, intent(in), optional :: ldb
      LOGICAL     :: ldb_local
      INTEGER     :: ier
      real(rprec) :: dx,dy,dz,xp,yp,zp,bx,by,bz
      REAL(rprec) :: xvec(3),bvec(3)
!-----------------------------------------------------------------------
!     Begin Function
!-----------------------------------------------------------------------
      dx = x1-x0
      dy = y1-y0
      dz = z1-z0
      xp = .5*(x0+x1)
      yp = .5*(y0+y1)
      zp = .5*(z0+z1)
      dl = 1.0
      ldb_local=.false.
      IF (PRESENT(ldb)) ldb_local = ldb
      IF (cg > 0) THEN
         xvec(1)=xp
         xvec(2)=yp
         xvec(3)=zp
         CALL bsc_b(coil_group(cg),xvec,bvec)
         dflux_midpoint = bvec(1)*dx+bvec(2)*dy+bvec(3)*dz
      ELSE
         ier = 1
         CALL bfield_vc(xp,yp,zp,bx,by,bz,ier)
         !CALL bfield_virtual_casing_adapt(xp,yp,zp,bx,by,bz,ier)
         !CALL bfield_volint_adapt(xp,yp,zp,bx,by,bz,ier)
         db_midpoint = bx*dx+by*dy+bz*dz
      END IF
      IF (ldb_local) db_midpoint = db_midpoint/SQRT(dx*dx+dy*dy+dz*dz)
      RETURN
!-----------------------------------------------------------------------
!     End Function
!-----------------------------------------------------------------------
      END FUNCTION db_midpoint


      subroutine posnoa (month,jday,tu,nc,xlonan,hna,campm,
     a                   asol,phi0,avis,phiv,xlon,xlat)
      logical ier
      real tu,xlonan,hna,asol,phi0,avis,phiv,xlon,xlat,campm
      real pi,r,ai,an,ylonan,t,hnam,u,delt,d,y,z
      real ylat,cosy,siny,ylon,ylo1,zlat,zlon,xnum,xden
      integer month,jday,nc,iwr
      common/sixs_ier/iwr,ier

c     noaa 6 definition
c     orbite inclination ai in radians
c     hor mouv in rad/s  an
c     h/r=860/6378
c     campm allows the user to switch to pm platforms

      pi=3.1415926
      r=860./6378.155
      ai=98.96*pi/180.
      an=360.*pi/(6119.*180.)
      ylonan=xlonan*pi/180.
      t=tu*3600
      hnam=hna
      hnam=hnam*3600
      u=t-hnam
      u=campm*u*an
      delt=((nc-(2048+1)/2.)*55.385/((2048.-1)/2.))
      delt=campm*delt*pi/180.
      avis=asin((1+r)*sin(delt))
      d=avis-delt
      y=cos(d)*cos(ai)*sin(u)-sin(ai)*sin(d)
      z=cos(d)*sin(ai)*sin(u)+cos(ai)*sin(d)
      ylat=asin(z)
      cosy=cos(d)*cos(u)/cos(ylat)
      siny=y/cos(ylat)
      ylon=asin(siny)
      if(cosy.gt.0.)goto 10
      if(siny.gt.0) ylon=pi-ylon
      if(siny.le.0) ylon=-(pi+ylon)
 10   ylo1=ylon+ylonan-(t-hnam)*2.*pi/86400.
      xlat=ylat*180./pi
      xlon=ylo1*180./pi

      call possol(month,jday,tu,xlon,xlat,
     a            asol,phi0)
      if(ier)return

      zlat=asin(sin(ai)*sin(u))
      zlon=atan2(cos(ai)*sin(u),cos(u))
      if(nc.ne.1024)then
      xnum=sin(zlon-ylon)*cos(zlat)/sin(abs(d))
      xden=(sin(zlat)-sin(ylat)*cos(d))/cos(ylat)/sin(abs(d))
      phiv=atan2(xnum,xden)
      else
      phiv=0.
      endif
      phiv=phiv*180./pi
      avis=abs(avis)
      avis=avis*180./pi
      return
      end


MODULE areamod

  USE prms
  USE data
  USE membrane

  IMPLICIT none

CONTAINS

  SUBROUTINE adjustareas(X)
    real, dimension(2,Nb,Nm)    :: X
    real, dimension(Nm)      :: A

    real                     :: Atot

    real, parameter          :: fac=1.0001

!!$    call areas(X,A)
!!$
!!$    Atot = SUM(A)
!!$
!!$    if (Atot/tau0.lt.0.55) then
!!$       print *,"grow",Atot/tau0
!!$       dSo = dSo*fac
!!$       Soe = Soe*fac
!!$       len0 = len0*fac
!!$       rad = rad*fac
!!$    else
!!$       print *,Atot/tau0
!!$    end if

  END SUBROUTINE adjustareas

  SUBROUTINE areas(X,A)
    real, dimension(2,Nb,Nm)    :: X
    real, dimension(Nm)      :: A

    real, dimension(Nb) :: x1,x2,dy
    integer :: m

    do m = 1,Nm
       x1 = X(1,:,m)
       x2 = X(2,:,m)

       call dersp(x2,len0(m),dy)

       A(m) = SUM(x1*dy)*dSo((m-1)*Nb + 1)
    end do

  END SUBROUTINE areas

  SUBROUTINE correctareas(X)
    real, dimension(2,Nb,Nm) :: X

    real, dimension(Nb)      :: dx1,dy1,D,x1,x2
    real, dimension(2,Nb)    :: nvec
    real, dimension(Nm)      :: A
    real , dimension(Nm)     :: Ao

    real, parameter :: eps = 0.0001
    integer         :: m

    call areas(X,A)
!    print *,MAXVAL(A),MINVAL(A)

    Ao = Pi*rad**2

    do m = 1,Nm
       !  if (ABS(A(m)-Ao)/Ao.gt.4.*eps) then

       x1 = X(1,:,m)
       x2 = X(2,:,m)
       call dersp(x1,len0(m),dx1)
       call dersp(x2,len0(m),dy1)

       D = SQRT(dx1**2 + dy1**2)

       nvec(1,:) = dy1/D
       nvec(2,:) = -dx1/D

       X(:,:,m) = X(:,:,m) + (Ao(m)-A(m))/SUM(D)*dSo((m-1)*Nb+1)*nvec

    end do

    call areas(X,A)
!    print *,"AFTER",MAXVAL(A),MINVAL(A)

  END SUBROUTINE correctareas

END MODULE areamod


    program AOC18

    implicit none

    integer, parameter :: I8 = selected_int_kind(15)
    character(*), parameter :: inpfile = 'input.txt'

    type sn_t
        type(sn_t), pointer :: left => null()
        type(sn_t), pointer :: right => null()
        type(sn_t), pointer :: up => null()
        integer(I8) :: val = 0, depth = 0, curnum = 0
    end type sn_t
    type(sn_t), pointer :: curval, newval
    type nums_t
        type(sn_t), pointer :: num
    end type nums_t
    type(nums_t) :: nums(500)
    integer :: curnum, lastnum
    character(100) :: line
    integer :: curpos, ios
    logical :: action_taken

    open (unit=1,file=inpfile,form='formatted',status='old')

    curval => null()
    do
        read (1,'(A)',iostat=ios) line
        if (ios /= 0) exit
        curpos = 0
        newval => read_nums()
        if (.not. associated(curval)) then
            curval => newval
        else
            curval => add (curval,newval)
        end if
        action_taken = .true.
        do while (action_taken)
            action_taken = .false.
            lastnum = 0
            call traverse(curval,1)
            call explode(curval)
            if (action_taken) cycle
            call split(curval)
        end do
    end do

    print *, magnitude(curval)

    contains

    recursive function read_nums() result(res)
    type(sn_t), pointer :: res

    allocate (res)
    curpos = curpos + 1
    select case (line(curpos:curpos))
    case ('[')
        res%left => read_nums()
        curpos = curpos + 1
        call errcheck(',')
        res%right => read_nums()
        curpos = curpos + 1
        call errcheck(']')
        res%left%up => res
        res%right%up => res
    case ('0':'9')
        res%val = ichar(line(curpos:curpos)) - ichar('0')
        !call errcheck(']')
    case default
        call errcheck(' ')
    end select
    return
    end function read_nums

    subroutine errcheck (expected)
    character, intent(in) :: expected
    if (expected == ' ') then
        print *, "Unexpected character '",line(curpos:curpos),"' at position ", curpos
    else if (line(curpos:curpos) /= expected) then
        print *, "Expected '",expected,"' but found '",line(curpos:curpos),"' at position ", curpos
    else
        return
    end if
    error stop
    end subroutine errcheck

    function add (left,right) result (res)
    type(sn_t), pointer :: res
    type(sn_t), pointer, intent(in) :: left, right

    allocate (res)
    res%left => left
    res%right => right
    end function add

    recursive subroutine traverse (val,depth)
    type(sn_t), pointer, intent(inout) :: val
    integer, intent(in) :: depth
    val%depth = depth
    if (.not. associated(val%left)) then
        lastnum = lastnum + 1
        nums(lastnum)%num => val
        val%curnum = lastnum
    else
        call traverse(val%left,depth+1)
        call traverse(val%right,depth+1)
    end if
    end subroutine traverse

    recursive subroutine explode (pair)
    type(sn_t), pointer, intent(in) :: pair
    type(sn_t), pointer :: left,right
    integer :: pos

    left => pair%left
    right => pair%right
    if (.not. associated(left)) return
    if ((pair%depth > 4) .and. (.not. associated(left%left)) .and. (.not. associated(right%right))) then
        ! Explode this pair
        pos = left%curnum - 1
        if (pos > 0) then
            nums(pos)%num%val = nums(pos)%num%val + left%val
        end if
        pos = right%curnum + 1
        if (pos <= lastnum) then
            nums(pos)%num%val = nums(pos)%num%val + right%val
        end if
        deallocate (pair%left)
        deallocate (pair%right)
        pair%val = 0
        action_taken = .true.
    else
        if (.not. action_taken) call explode(left)
        if (.not. action_taken) call explode(right)
    end if
    end subroutine explode

    subroutine split (cv)
    type(sn_t), pointer, intent(inout) :: cv
    type(sn_t), pointer :: sn
    integer :: i

    lastnum = 0
    call traverse(cv,1)
    do i=1,lastnum
        sn => nums(i)%num
        if (sn%val >= 10) then
            allocate (sn%left)
            allocate (sn%right)
            sn%left%val = sn%val/2
            sn%right%val = ceiling(real(sn%val)/2.0)
            sn%val = 0
            action_taken = .true.
            return
        end if
    end do
    end subroutine split

    recursive function magnitude (pair)
    integer :: magnitude
    type (sn_t), pointer, intent(in) :: pair

    if (.not. associated(pair%left)) then
        magnitude = pair%val
    else
        magnitude = (3*magnitude(pair%left)) + (2*magnitude(pair%right))
    end if
    end function magnitude

    recursive subroutine printval (val)
    type(sn_t), intent(in) :: val
    if (.not. associated(val%left)) then
        write (*,'(I0)',advance='no') val%val
    else
        write (*,'(A)',advance='no') '['
        call printval(val%left)
        write (*,'(A)',advance='no') ','
        call printval(val%right)
        write (*,'(A)',advance='no') ']'
    end if
    end subroutine printval

    end program AOC18


       subroutine conv_lor(gamma, mpts, x, y, step, yout)
c
c  broaden an array with a lorentzian of width gamma
c  typically used for broadening an energy-dependent array
c
c  arguments:
c    gamma   lorenztian width (in eV)                [in]
c    mpts    size of x,y arrays                      [in]
c    x       array of x (energy)  values             [in]
c    y       array of y (ordinate values to broaden  [in]
c    step    step size (can be zero, see note)       [in]
c    yout    broadened array y(x)                    [out]
c
c  note:
c    for the convolution to work properly, the y(x) data
c    needs to be on an even x-grid.  this is done here, so
c    that input data does not need to be on an even grid.
c
c    if step is non-zero, that will be used as the grid spacing
c    if step is zero, the grid spacing will be found from the
c    data itself, as the smallest spacing in the input x array.
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1999--2001 Matthew Newville, The University of Chicago
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, or the authors appear in advertising or
c endorsement of works derived from this software without specific
c prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
       implicit none
       include 'maxpts.h'
       integer npts, i, j, mpts, ipos, nx1
       double precision x(*), y(*), yout(*), step, st, xt
       double precision gamma, sum, factr, zero,  small
       double precision tmpy, dx, gami, ytmp(maxpts)
       double precision xtmp(maxpts), tmp(maxpts)
       parameter  (zero = 0.d0, small = 1.d-9)

       st   = step
       npts = min(maxpts,mpts)
       if (npts.le.2)  return
       gami = 4.d0/(gamma*gamma)
c
c if step is too small (ie, zero) determine it from data
       if (st.le.small)  then
	  st = abs(x(2) - x(1))
          do 100 i = 3, npts
	    xt = abs(x(i) - x(i-1))
            if (xt.ge.small) st = min(st,xt)
 100     continue
       end if
c make sure step size / npts is OK....
 105   continue
       nx1   = 1 + int( (x(npts) - x(1) + small)  / st)
       if (nx1.gt.maxpts) then
          st = st + st
          goto 105
       endif

c linearly interpolate onto even x grid
       ipos  = 1
       do 200 i = 1, nx1
          xtmp(i) = (i-1) * st + x(1)
          call lintrp(x, y, npts, xtmp(i), ipos, ytmp(i))
 200   continue
c
c convolve
       do 500 i = 1, nx1
          sum  = zero
          tmpy = zero
          do 400 j = 1, nx1
             dx    = xtmp(j) - xtmp(i)
             factr = 1 / ( 1 + dx * dx  * gami)
             sum   = sum  + factr
             tmpy  = tmpy + ytmp(j) *  factr
 400      continue
          tmp(i) = tmpy / max(small, sum)
 500   continue
c
c put result back on input x-array
       ipos = 0
       do 700 i = 1, npts
          call lintrp(xtmp, tmp, nx1, x(i), ipos, yout(i))
 700   continue
c
       return
       end

       subroutine conv_gau(gamma, mpts, x, y, step, yout)
c
c  broaden an array with a gaussian of width gamma
c  typically used for broadening an energy-dependent array
c
c  arguments:
c    gamma   lorenztian width (in eV)                [in]
c    mpts    size of x,y arrays                      [in]
c    x       array of x (energy)  values             [in]
c    y       array of y (ordinate values to broaden  [in]
c    step    step size (can be zero, see note)       [in]
c    yout    broadened array y(x)                    [out]
c
c  note:
c    for the convolution to work properly, the y(x) data
c    needs to be on an even x-grid.  this is done here, so
c    that input data does not need to be on an even grid.
c
c    if step is non-zero, that will be used as the grid spacing
c    if step is zero, the grid spacing will be found from the
c    data itself, as the smallest spacing in the input x array.
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1999--2001 Matthew Newville, The University of Chicago
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, or the authors appear in advertising or
c endorsement of works derived from this software without specific
c prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
       implicit none
       include 'maxpts.h'
       integer npts, i, j, mpts, ipos, nx1
       double precision x(*), y(*), yout(*), step, st, xt
       double precision gamma, sum, factr, zero,  small
       double precision tmpy, dx, gami, ytmp(maxpts)
       double precision xtmp(maxpts), tmp(maxpts)
       parameter  (zero = 0.d0, small = 1.d-12)

       st   = step
       npts = min(maxpts,mpts)
       if (npts.le.2)  return
       gami = 1.d0/(2*gamma*gamma)
c
c if step is too small (ie, zero) determine it from data
       if (st.le.small)  then
	  st = abs(x(2) - x(1))
          do 100 i = 3, npts
	    xt = abs(x(i) - x(i-1))
            if (xt.ge.small) st = min(st,xt)
 100     continue
       end if
c make sure step size / npts is OK....
 105   continue
       nx1   = 1 + int( (x(npts) - x(1) + small)  / st)
       if (nx1.gt.maxpts) then
          st = st + st
          goto 105
       endif
c
c linearly interpolate onto even x grid
       ipos  = 1
       do 200 i = 1, nx1
          xtmp(i) = (i-1) * st + x(1)
          call lintrp(x, y, npts, xtmp(i), ipos, ytmp(i))
 200   continue
c
c convolve
       do 500 i = 1, nx1
          sum  = zero
          tmpy = zero
          do 400 j = 1, nx1
             dx    = xtmp(j) - xtmp(i)
             factr = exp(-gami*dx*dx)
             sum   = sum  + factr
             tmpy  = tmpy + ytmp(j) *  factr
 400      continue
          tmp(i) = tmpy / max(small, sum)
 500   continue
c
c put result back on input x-array
       ipos = 0
       do 700 i = 1, npts
          call lintrp(xtmp, tmp, nx1, x(i), ipos, yout(i))
 700   continue
c
       return
       end

       subroutine do_gauss(x,mpts,cen,wid,out)
c
c  simple calculation of true gaussian function on input
c  array x
c    gauss(x,cen,wid) = 1/[wid*sqrt(2pi)] * exp[-(x-cen)^2/(2*wid^2)]
c
c  arguments:
c    x       array of x values             [in]
c    mpts    size of x,y arrays            [in]
c    cen     centroid of gaussian          [in]
c    wid   width of gaussian             [in]
c    out     array of output values        [out]
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1999--2001 Matthew Newville, The University of Chicago
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, or the authors appear in advertising or
c endorsement of works derived from this software without specific
c prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
       implicit none
       include 'maxpts.h'
       integer npts, i, j, mpts
       double precision x(*), out(*), cen, wid
       double precision one,small,scale, escal, s2pi
       parameter (one  = 1.d0, small = 1.d-12)
c s2pi = 1 / sqrt(2*pi)
       parameter (s2pi = 0.3989422804014327d0)

c
       wid   =  max(small, wid)
       scale =  s2pi/ wid
       escal = -one / (2 * wid * wid)
       do 100 i = 1, mpts
          out(i) = scale * exp(escal*(x(i) - cen)*(x(i) - cen))
 100   continue
c
       return
       end

       subroutine do_loren(x,mpts,cen,wid,out)
c
c  simple calculation of true lorenztian function on input
c  array x
c    loren(x,cen,wid) = wid/(2*pi) * [ (x-cen)^2 + (wid/2)^2]^(-1)
c
c  arguments:
c    x       array of x values             [in]
c    mpts    size of x,y arrays            [in]
c    cen     centroid of lorentzian        [in]
c    wid     width of lorentzian           [in]
c    out     array of output values        [out]
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1999--2001 Matthew Newville, The University of Chicago
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, or the authors appear in advertising or
c endorsement of works derived from this software without specific
c prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
       implicit none
       include 'maxpts.h'
       integer npts, i, j, mpts
       double precision x(*), out(*), cen, wid
       double precision four, small,scale, wid2, pi, pi2
       parameter (four = 4.d0, small = 1.d-12)
       parameter (pi   = 3.141592653589793d0)
       parameter (pi2  = 2.d0 * pi)
c
c    loren(x,cen,wid) = wid/(2*pi) * [ (x-cen)^2 + (wid/2)^2]^(-1)

       wid   = max(small, wid)
       scale = wid / pi2
       wid2  = wid * wid / four
       do 100 i = 1, mpts
          out(i) = scale / ((x(i)-cen)*(x(i)-cen) + wid2)
 100   continue
c
       return
       end

       subroutine do_pvoight(x,mpts,cen,fwhm,frac,out)
c
c  simple calculation of pseudo-voight as weighted sum
c  of lorenztian and gaussian functions
c   voight(x,cen,wid,frac) = frac *loren(x,cen,wid) +
c                           (1-frac)*gauss(x,cen,wid)
c
c  arguments:
c    x       array of x values             [in]
c    mpts    size of x,y arrays            [in]
c    cen     centroid of loren/gauss       [in]
c    wid     width of loren/gauss          [in]
c    frac    fraction for lorentzian       [in]
c    out     array of output values        [out]
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1999--2001 Matthew Newville, The University of Chicago
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, or the authors appear in advertising or
c endorsement of works derived from this software without specific
c prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
       implicit none
       include 'maxpts.h'
       integer npts, i, j, mpts
       double precision x(*), out(*), cen, fwhm, frac
       double precision  tmp(maxpts), sig, conv
c   conv = 1/ (2 * sqrt(2*log(2)))
       parameter (conv = 0.424660900144d0)

       sig = fwhm * conv
       call do_loren(x,mpts,cen,fwhm,out)
       call do_gauss(x,mpts,cen,sig,tmp)
       do 100 i = 1, mpts
          out(i) = frac*out(i) + (1-frac)*tmp(i)
 100   continue
c
       return
       end


! Copyright (c) 2012-2013 Bartosz Szczesny
! LICENSE: The MIT License (MIT)

program external_function
    interface
        function cube( x )
            real :: cube, x
        end function
    end interface

    real :: x = 4
    print "( f4.1, a, f4.1 )", x, "**3 = ", cube( x )

    stop
end program

real function cube( x )
    real :: x
    cube = x**3
    return
end function


! Write a function that combines two lists by alternatingly taking elements, e.g. [a,b,c], [1,2,3] -> [a,1,b,2,c,3].

    program Exercises
        implicit none

        integer :: listA(3)
        integer :: listB(5)
        integer :: alternate(8)

        listA = (/ 5, 2, 3 /)
        listB = (/ 9, 1, 777, 0, 6 /)
        alternate = alternateElements(listA, listB)

        contains

        function alternateElements(listA, listB) result(res)
            ! This is set up to permit input arrays of different sizes. If they are different sizes, it will
            ! stop alternating and finish up by picking elements from the end of the bigger array.
            integer, dimension(:), intent(in) :: listA
            integer, dimension(:), intent(in) :: listB

            integer :: res(size(listA) + size(listB))
            integer :: listIndexA
            integer :: listIndexB
            integer :: resultIndex

            listIndexA = 1
            listIndexB = 1
            resultIndex = 1

            do while (resultIndex .le. size(res))
                if (listIndexA .le. size(listA)) then
                    res(resultIndex) = listA(listIndexA)
                    listIndexA = listIndexA + 1
                    resultIndex = resultIndex + 1
                end if

                if (listIndexB .le. size(listB)) then
                    res(resultIndex) = listB(listIndexB)
                    listIndexB = listIndexB + 1
                    resultIndex = resultIndex + 1
                end if
            end do

        end function alternateElements

    end program Exercises


!
SUBROUTINE fc2d_geoclaw_setaux(mbc,mx,my,xlow,ylow,dx,dy,maux,aux, &
                               is_ghost_in,nghost,mint)
  !!     ============================================
  !!
  !!     # set auxiliary arrays
  !!
  !!     aux(1,i,j) = Z(x,y) topography (negative below sea level for topoymetry)
  !!
  !!     If coordinate_system=2 then lat-lon coordinates on the sphere and
  !!        aux(2,i,j) = area ratio (capacity function -- set mcapa = 2)
  !!        aux(3,i,j) = length ratio for edge
  !!
  !!

  USE amr_module, ONLY: mcapa, xupper, yupper, xlower, ylower, NEEDS_TO_BE_SET

  USE geoclaw_module, ONLY: coordinate_system, earth_radius, deg2rad
  USE geoclaw_module, ONLY: sea_level, ambient_pressure

  USE storm_module, ONLY: wind_forcing, pressure_forcing
  USE storm_module, ONLY: wind_index, pressure_index, set_storm_fields

  USE friction_module, ONLY: variable_friction, friction_index
  USE friction_module, ONLY: set_friction_field

  USE topo_module

  IMPLICIT NONE

  !! Arguments
  INTEGER, INTENT(in) :: mbc,mx,my,maux
  REAL(kind=8), INTENT(in) :: xlow,ylow,dx,dy
  REAL(kind=8), INTENT(inout) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)
  integer, intent(in) :: nghost, mint
  INTEGER, INTENT(in) :: is_ghost_in
  LOGICAL*1 :: is_ghost

  !! Locals
  INTEGER :: ii,jj,m, iint,jint
  REAL(kind=8) :: x,y,xm,ym,xp,yp,topo_integral
  CHARACTER(len=*), PARAMETER :: aux_format = "(2i4,4d15.3)"
  INTEGER :: skipcount,iaux,ilo,jlo
  LOGICAL ghost_invalid

  is_ghost = is_ghost_in .ne. 0

  !! Lat-Long coordinate system in use, check input variables
  IF (coordinate_system == 2) THEN
     IF (mcapa /= 2 .OR. maux < 3) THEN
        PRINT *,'ERROR in setaux:  for coordinate_system==2'
        PRINT *,'     need mcapa == 2 and maux >= 3'
        PRINT *,'     have mcapa = ',mcapa,'  maux = ',maux
        STOP
     ENDIF
  ENDIF

  !! Check below is new in 5.2.1 -- need to rethink for storm surge
  !! and other applications where other aux arrays might be used?
  IF (coordinate_system == 1) THEN
     IF (mcapa > 0) THEN
        PRINT *,'ERROR in setaux:  for coordinate_system==1'
        PRINT *,'     need mcapa == 0 and maux == 1'
        PRINT *,'     have mcapa = ',mcapa,'  maux = ',maux
        STOP
     ELSE IF (maux > 1) THEN
        !! Should not need to set aux(2,:,:) in this case, but
        !! for some reason it bombs, e.g. in bowl-radial if maux>1.
        do jj = 1-mbc,my+mbc
          do ii = 1-mbc,mx+mbc
            if (is_ghost .and. ghost_invalid(ii,jj,mx,my,nghost,mint)) then
              cycle
            endif
            aux(2,ii,jj) = 1.d0
          enddo
        enddo
     ENDIF
  ENDIF

  !! If using a variable friction field initialize the coefficients to 0
  IF (variable_friction) THEN
    do jj = 1-mbc,my+mbc
      do ii = 1-mbc,mx+mbc
        if (is_ghost .and. ghost_invalid(ii,jj,mx,my,nghost,mint)) then
          cycle
        endif
        aux(friction_index,ii,jj) = 0.d0
      enddo
    enddo
  ENDIF

    !! Storm fields if used
  IF (wind_forcing) THEN
    do jj = 1-mbc,my+mbc
      do ii = 1-mbc,mx+mbc
        if (is_ghost .and. ghost_invalid(ii,jj,mx,my,nghost,mint)) then
          cycle
        endif
        aux(wind_index,ii,jj) = 0.d0
        aux(wind_index + 1,ii,jj) = 0.d0
      enddo
    enddo
  ENDIF

  IF (pressure_forcing) THEN
    do jj = 1-mbc,my+mbc
      do ii = 1-mbc,mx+mbc
        if (is_ghost .and. ghost_invalid(ii,jj,mx,my,nghost,mint)) then
          cycle
        endif
        aux(pressure_index,ii,jj) = ambient_pressure
      enddo
    enddo
  ENDIF

  !! Set analytical bathymetry here if requested
  IF (test_topography > 0) THEN
    do jj = 1-mbc,my+mbc
      do ii = 1-mbc,mx+mbc
        if (is_ghost .and. ghost_invalid(ii,jj,mx,my,nghost,mint)) then
          cycle
        endif
        aux(1,ii,jj) = test_topo(xlow + (ii - 0.5d0) * dx,       &
            ylow + (jj - 0.5d0) * dy)
      enddo
    enddo
  ENDIF

  !! test:  compute integer indices based off same corner of domain
  !!        to reduce round off discrepancies
  ilo = FLOOR((xlow - xlower + .05d0*dx)/dx)
  jlo = FLOOR((ylow - ylower + .05d0*dy)/dy)

  !! Set bathymetry
  skipcount = 0
  DO jj=1-mbc,my+mbc
     !!ym = ylow + (jj - 1.d0) * dy
     !!y = ylow + (jj - 0.5d0) * dy
     !!yp = ylow + real(jj,kind=8) * dy

     ym = ylower + (jlo+jj-1.d0) * dy
     yp = ylower + (jlo+jj) * dy
     y = 0.5d0*(ym+yp)

     DO ii=1-mbc,mx+mbc
        !!xm = xlow + (ii - 1.d0) * dx
        !!x  = xlow + (ii - 0.5d0) * dx
        !!xp = xlow + real(ii,kind=8) * dx

        xm = xlower + (ilo+ii-1.d0) * dx
        xp = xlower + (ilo+ii) * dx
        x = 0.5d0*(xm+xp)

        !!write(*,444)ii,jj,aux(1,ii,jj)
444     FORMAT("in setaux ",2i4,e12.5)

        IF (is_ghost .AND. ghost_invalid(ii,jj,mx,my,nghost,mint)) THEN
           CYCLE
        ENDIF

        !! Set lat-long cell info
        IF (coordinate_system == 2) THEN
           aux(2,ii,jj) = deg2rad * earth_radius**2 * (SIN(yp * deg2rad) - SIN(ym * deg2rad)) / dy
           aux(3,ii,jj) = ym * deg2rad
        ENDIF

        !! skip setting aux(1,ii,jj) in ghost cell if outside physical domain
        !! since topo files may not cover ghost cell, and values
        !! should be extrapolated, which is done in next set of loops.
        IF ((y>yupper) .OR. (y<ylower) .OR. &
             (x>xupper) .OR. (x<xlower)) CYCLE

#if 0
        !! ### parameter NEEDS_TO_BE_SET initialized in amr_module.f90
        !! ### saves time by otherwise copying instead of reinitializing
        !! FORESTCLAW change
        IF (aux(1,ii,jj) .NE. NEEDS_TO_BE_SET) THEN
           skipcount = skipcount + 1
           CYCLE  ! new system copies bathy where possible
        ENDIF
#endif

        !! Use input topography files if available
        IF (mtopofiles > 0 .AND. test_topography == 0) THEN
           topo_integral = 0.d0
           CALL cellgridintegrate(topo_integral,xm,x,xp,ym,y,yp, &
                xlowtopo,ylowtopo,xhitopo,yhitopo,dxtopo,dytopo, &
                mxtopo,mytopo,mtopo,i0topo,mtopoorder, &
                mtopofiles,mtoposize,topowork)

           IF (coordinate_system == 2) THEN
              aux(1,ii,jj) = topo_integral / (dx * dy * aux(2,ii,jj))
           ELSE
              aux(1,ii,jj) = topo_integral / (dx * dy)
           ENDIF
        ENDIF
     ENDDO
  ENDDO
  !!write(*,*)" skipcount = ",skipcount

  !! Copy topo to ghost cells if outside physical domain

  DO jj=1-mbc,my+mbc
     y = ylower + (jlo+jj-.5d0) * dy
     IF ((y < ylower) .OR. (y>yupper)) THEN
        DO ii=1-mbc,mx+mbc
           if (is_ghost .and. ghost_invalid(ii,jj,mx,my,nghost,mint)) then
             cycle
           endif
           x = xlower + (ilo+ii-.5d0) * dx
           iint = ii + MAX(0, CEILING((xlower-x)/dx)) &
                - MAX(0, CEILING((x-xupper)/dx))
           jint = jj + MAX(0, CEILING((ylower-y)/dy)) &
                - MAX(0, CEILING((y-yupper)/dy))
           aux(1,ii,jj) = aux(1,iint,jint)
        ENDDO
     ENDIF
  ENDDO

  DO ii=1-mbc,mx+mbc
     x =  xlower + (ilo+ii-.5d0) * dx
     IF ((x < xlower) .OR. (x > xupper)) THEN
        DO jj=1-mbc,my+mbc
           if (is_ghost .and. ghost_invalid(ii,jj,mx,my,nghost,mint)) then
             cycle
           endif
           y = ylower + (jlo+jj-.5d0) * dy
           iint = ii + MAX(0, CEILING((xlower-x)/dx)) &
                - MAX(0, CEILING((x-xupper)/dx))
           jint = jj + MAX(0, CEILING((ylower-y)/dy)) &
                - MAX(0, CEILING((y-yupper)/dy))
           aux(1,ii,jj) = aux(1,iint,jint)
        ENDDO
     ENDIF
  ENDDO

  !! Set friction coefficient based on a set of depth levels
  IF (friction_index > 0) THEN
     CALL set_friction_field(mx,my,mbc,maux,xlow,ylow,dx,dy,aux &
                             ,is_ghost,nghost,mint)
  ENDIF

  !! Output for debugging to fort.23
  IF (.FALSE.) THEN
     PRINT *,'Writing out aux arrays'
     PRINT *,' '
     WRITE(23,230)  mbc,mx,my,dx,dy,xlow,ylow
230  FORMAT('==> mbc, mx, my:  ',3i5,'  dx, dy:',2f10.6, &
          '  xlow,ylow:', 2f10.6)
     DO jj=1-mbc,my+mbc
        DO ii=1-mbc,mx+mbc
           x = xlow + (ii-0.5d0)*dx
           y = ylow + (jj-0.5d0)*dy
           IF ((x>223) .AND. (x<232) .AND. (y<37)) &
                WRITE(23,231) ii,jj,x,y,(aux(m,ii,jj),m=1,maux)
231        FORMAT(2i4,2f10.3,3e20.10)
        ENDDO
     ENDDO
  ENDIF

END SUBROUTINE fc2d_geoclaw_setaux

!! Change this to ghost_valid
LOGICAL FUNCTION ghost_invalid(i,j,mx,my,nghost,mint)
  implicit none
  integer, intent(in) :: i,j,nghost,mint,mx,my
  logical :: inner, outer

  inner = (i .gt. mint .and. i .lt. mx-mint+1) .and. &
          (j .gt. mint .and. j .lt. my-mint+1)

  outer = (i .lt. 1-nghost) .or. (i .gt. mx+nghost) .or. &
          (j .lt. 1-nghost) .or. (j .gt. my+nghost)

  ghost_invalid = (inner .or. outer)
end function ghost_invalid


      PROGRAM drsdasl2
c>> 2009-10-27 DRSDASL2 Krogh Declared DUM(4,*) for NAG compiler.
c>> 2009-10-19 DRSDASL2 Krogh Changed def. of d(4,4) so 0 doesn't abort.
c>> 2008-10-26 DRSDASL2 Krogh Moved Format statements up for C conv.
c>> 2008-10-24 DRSDASL2 Krogh Removed in INCLUDE statement & cDEC$...
C>> 2008-09-04 DRSDASL2 Hanson added starting computation of y'
C>> 2008-08-26 DRSDASL2 Hanson added row dimensions to evaluators
C>> 2001-10-11 DRSDASL2  R. J. Hanson Example 2 Code, with Download

C     Solve Enright and Pryce stiff test problem E5.
C     The equation is presented as y'= F(t,y), y_0 given.
C     This is solved by defining the residual function
C     f(t,y,y')=F(t,y)-y'.  Integration is done twice.

C     The first time analytic partials are provided.

C     The second time, difference quotients are used for
C     partials, with the integrator requesting only values
C     of f(t,y,y').  The two solutions are equivalent but
C     not exactly equal.

C--S replaces "?": DR?DASL2, ?DASLS, ?DASLX, ?DASSF2, ?DASSF3, ?COPY
C-- & ?ROTG
      EXTERNAL sdassf2,sdassf3
      INTEGER ndig,nepoch,neq,maxcon,ldc,ltd,lrw,liw
C     Set number of equations:
      PARAMETER  (neq=4)
C     Set number of constraints.
      PARAMETER  (maxcon=0)
C     Work space sizes:
      PARAMETER  (liw=30+neq)
      PARAMETER  (lrw=45+(5+2*maxcon+4)*neq+neq**2)
      PARAMETER  (ldc=neq,ltd=neq)
      REAL             tol
C++S Default NDIG = 3
C++  Default NDIG = 8
C++ Substitute for NDIG below
      PARAMETER  (ndig=3,nepoch=10)
      PARAMETER  (tol=10.e0**(-ndig))
      INTEGER i,j,info(16),idid,iwork(liw)
      REAL             t,y(neq),yprime(neq),rtol(neq),atol(neq),
     & rwork(lrw),tout(nepoch),y1(neq,nepoch),y2(neq,nepoch)
      REAL             c(ldc,ltd),ftol,rnktol
      LOGICAL match
      INTEGER kf2,ks2,kf3,ks3
      COMMON /counts/ kf2,ks2,kf3,ks3
   90 FORMAT (/20x,'Example Results for a Stiff ODE Problem, E5')
  100 FORMAT (6x,'Integration Values do not Match')
  110 FORMAT (/15x,'No. of Residual Evaluations',6x,'No. of User Solves'
     & /' Partials Provided-',8x,i4,24x,i4)
  120 FORMAT (' Divided Differences-',6x,i4,24x,i4)
  130 FORMAT (/10x,'T',7x,'RErr in y_1',3x,'RErr in y_2',3x,'RErr in y_3
     & ',3x,'RErr in y_4')
  140 FORMAT (1p,5d14.4)

C     Tolerances:
      DO 10 i=1,neq
        atol(i)=tol
        rtol(i)=tol
   10 CONTINUE
C     Setup options:
      DO 20 i=1,16
        info(i)=0
   20 CONTINUE
C Compute, factor and solve the partial derivative matrix in routine
C SDASSF2. This illustrates how to completely control the linear
C algebra. Using analytic partial derivatives.
      info(5)=5
C     Compute the initial value of YPRIME(*):
      t=0
      ftol=tol
      rnktol=tol
C     Give starting values to y and y' before Newton method:
      do 25 i = 1, neq
        y(i) = 0.E0
        yprime(i) = 0.E0
 25   continue
      y(1) = 1.76E-3
      CALL sdasls (sdassf2, neq, t, y, yprime, info, ftol, rnktol, c,
     & ldc, ltd, idid, rwork, lrw, iwork, liw)
C     Set output points for integration:
      tout(1)=0.e0
      tout(2)=1.e-3
      DO 30 i=3,nepoch
        tout(i)=10*tout(i-1)
   30 CONTINUE
      DO 40 i=2,nepoch
        t=tout(i-1)
        CALL sdaslx (sdassf2, neq, t, y, yprime, tout(i), info, rtol,
     &   atol, idid, rwork, lrw, iwork, liw)
        CALL scopy (neq, y, 1, y1(1,i), 1)
   40 CONTINUE
C     Compute the initial value of YPRIME(*):
      t=0
      ftol=tol
      rnktol=tol
C     Give starting values to y and y' before Newton method:
      do 45 i = 1, neq
        y(i) = 0.E0
        yprime(i) = 0.E0
 45   continue
      y(1) = 1.76E-3
      CALL sdasls (sdassf3, neq, t, y, yprime, info, ftol, rnktol, c,
     & ldc, ltd, idid, rwork, lrw, iwork, liw)
C     Restart the integration, but do not use analytic derivatives.
      info(1)=0
C     Use divided differences instead of user-provided partials.
C     And the default linear solver provided.
      info(5)=1
      DO 50 i=2,nepoch
        t=tout(i-1)
        CALL sdaslx (sdassf3, neq, t, y, yprime, tout(i), info, rtol,
     &   atol, idid, rwork, lrw, iwork, liw)
        CALL scopy (neq, y, 1, y2(1,i), 1)
   50 CONTINUE

C See if the solutions "match" the requested tolerances.
      match=.true.
      DO 70 j=2,nepoch
        DO 60 i=1,neq
          y2(i,j)=(y2(i,j)-y1(i,j))/(abs(y1(i,j))*rtol(i)+atol(i))
          match=match.and.(abs(y2(i,j)).le.100.e0)
   60   CONTINUE
   70 CONTINUE
C Output the relative errors and a summary.
      WRITE (*,90)
      WRITE (*,130)
      DO 80 j=2,nepoch
        WRITE (*,140) tout(j),(y2(i,j),i=1,neq)
   80 CONTINUE

      IF (match) THEN
        WRITE (*,110) kf2,ks2
        WRITE (*,120) kf3,ks3
      ELSE
        WRITE (*,100)
      END IF
      END

      SUBROUTINE sdassf2 (t, y, yprime, delta, dum, ldd, cj, ires,
     & rwork, iwork)
C
C     Routine for the Enright and Pryce problem E5.
C     DUM(*,*) is not used in this example.
      REAL             t,y(*),yprime(*),delta(*),dum(ldd,*),cj,rwork(*),
     & dc(3),ds(3),u,b0,b1,b2,b3,b4
      REAL             d(4,4)
      INTEGER i,ires,iwork(*),ldd
      SAVE  b0,b1,b2,b3,b4,d,dc,ds
      INTEGER kf2,ks2,kf3,ks3
      COMMON /counts/ kf2,ks2,kf3,ks3

C This is the setup call.
      IF (ires.eq.0) THEN
        b0=1.76e-03
        b1=7.89e-10
        b2=1.1e+07
        b3=1.13e+09
        b4=1.13e+03
C Set initial conditions.
        y(1)=0.e0
        CALL scopy (4, y, 0, y, 1)
        y(1)=b0
C Count evaluations in KF2 and KS2.
        kf2=0
        ks2=0
        RETURN
      END IF

C The sytem residual value:
      IF (ires.eq.1) THEN
        delta(1)=-b1*y(1)-b2*y(1)*y(3)-yprime(1)
        delta(2)=b1*y(1)-b3*y(2)*y(3)-yprime(2)
        delta(3)=b1*y(1)-b2*y(1)*y(3)+b4*y(4)-b3*y(2)*y(3)-yprime(3)
        delta(4)=b2*y(1)*y(3)-b4*y(4)-yprime(4)
        kf2=kf2+1
        RETURN
      END IF
C The partial derivative matrix:
      IF (ires.eq.2) THEN
        d(4,1)=b2*y(3)
        d(1,1)=-b1-d(4,1)-cj
        d(2,1)=b1
        d(3,1)=b1-d(4,1)

        d(1,2)=0.e0
        d(3,2)=-b3*y(3)
        d(2,2)=d(3,2)-cj
        d(4,2)=0.e0

        d(1,3)=-b2*y(1)
        d(2,3)=-b3*y(2)
        d(3,3)=d(1,3)+d(2,3)-cj
        d(4,3)=-d(1,3)

        d(1,4)=0.e0
        d(2,4)=0.e0
        d(3,4)=b4
        d(4,4)=-b4-cj

C This matrix is right factored to lower triangular for with three
C plane rotations.  Use planes 1 and 3:

C Tell integrator system is non-singular.
        ires=0

        CALL srotg (d(1,1), d(1,3), dc(1), ds(1))

        u=dc(1)*d(2,1)+ds(1)*d(2,3)
        d(2,3)=-ds(1)*d(2,1)+dc(1)*d(2,3)
        d(2,1)=u

        u=dc(1)*d(3,1)+ds(1)*d(3,3)
        d(3,3)=-ds(1)*d(3,1)+dc(1)*d(3,3)
        d(3,1)=u

        u=dc(1)*d(4,1)+ds(1)*d(4,3)
        d(4,3)=-ds(1)*d(4,1)+dc(1)*d(4,3)
        d(4,1)=u
        d(1,1)=1.e0/d(1,1)
C Eliminate in planes 2 and 3.
        CALL srotg (d(2,2), d(2,3), dc(2), ds(2))

        u=dc(2)*d(3,2)+ds(2)*d(3,3)
        d(3,3)=-ds(2)*d(3,2)+dc(2)*d(3,3)
        d(3,2)=u

        u=dc(2)*d(4,2)+ds(2)*d(4,3)
        d(4,3)=-ds(2)*d(4,2)+dc(2)*d(4,3)
        d(4,2)=u
        d(2,2)=1.e0/d(2,2)

C Eliminate in planes 3 and 4.
        CALL srotg (d(3,3), d(3,4), dc(3), ds(3))
        u=dc(3)*d(4,3)+ds(3)*d(4,4)
        d(4,4)=(-ds(3)*d(4,3)+dc(3)*d(4,4))
        if (d(4,4) .eq. 0.E0) then
          ires = 1
          return
        end if
        d(4,4) = 1.e0 / d(4,4)
        d(4,3)=u
        d(3,3)=1.e0/d(3,3)

        RETURN
      END IF

C Solve the corrector equation.
      IF (ires.eq.4) THEN
C Count number of solves.
        ks2=ks2+1

C Forward substitute:
        delta(1)=delta(1)*d(1,1)
        delta(4)=delta(4)-delta(1)*d(4,1)
        delta(3)=delta(3)-delta(1)*d(3,1)
        delta(2)=delta(2)-delta(1)*d(2,1)

        delta(2)=delta(2)*d(2,2)
        delta(4)=delta(4)-delta(2)*d(4,2)
        delta(3)=delta(3)-delta(2)*d(3,2)

        delta(3)=delta(3)*d(3,3)
        delta(4)=delta(4)-delta(3)*d(4,3)
        delta(4)=delta(4)*d(4,4)

C Apply three plane rotations,(3,4),(2,3),(1,3).
        u=dc(3)*delta(3)-ds(3)*delta(4)
        delta(4)=ds(3)*delta(3)+dc(3)*delta(4)
        delta(3)=u

        u=dc(2)*delta(2)-ds(2)*delta(3)
        delta(3)=ds(2)*delta(2)+dc(2)*delta(3)
        delta(2)=u

        u=dc(1)*delta(1)-ds(1)*delta(3)
        delta(3)=ds(1)*delta(1)+dc(1)*delta(3)
        delta(1)=u
        RETURN
      END IF
C This is df/dy' for the starting procedure.  This
C problem is a linear ODE.
      IF (ires.eq.7) THEN
        DO 10 i=1,4
          d(i,i)=-1.e0
   10   CONTINUE
        RETURN
      END IF

      END

      SUBROUTINE sdassf3 (t, y, yprime, delta, d, ldd, cj, ires, rwork,
     & iwork)
C
C     Routine for the Enright and Pryce problem E5.

      REAL             t,y(*),yprime(*),delta(*),d(ldd,4),cj,rwork(*),
     & dc(3),ds(3),b1,b2,b3,b4
      INTEGER ldd, ires,iwork(*)
      PARAMETER(b1=7.89e-10, b2=1.1e+07, b3=1.13e+09, b4=1.13e+03)
      INTEGER i,kf2,ks2,kf3,ks3
      COMMON /counts/ kf2,ks2,kf3,ks3

C This is the setup call.
      IF (ires.eq.0) THEN
C Count evaluations in KF3 and KS3.
        kf3=0
        ks3=0
      END IF

C The sytem residual value:
      IF (ires.eq.1) THEN
        delta(1)=-b1*y(1)-b2*y(1)*y(3)-yprime(1)
        delta(2)=b1*y(1)-b3*y(2)*y(3)-yprime(2)
        delta(3)=b1*y(1)-b2*y(1)*y(3)+b4*y(4)-b3*y(2)*y(3)-yprime(3)
        delta(4)=b2*y(1)*y(3)-b4*y(4)-yprime(4)
        kf3=kf3+1
      END IF
C The partial derivative matrix:
      IF (ires.eq.2) THEN
        d(4,1)=b2*y(3)
        d(1,1)=-b1-d(4,1)-cj
        d(2,1)=b1
        d(3,1)=b1-d(4,1)

        d(2,2)=-b3*y(3)-cj
        d(3,2)=d(2,2)
        d(1,3)=-b2*y(1)
        d(2,3)=-b3*y(2)
        d(3,3)=d(1,3)+d(2,3)-cj
        d(4,3)=-d(1,3)
        d(3,4)=b4
        d(4,4)=-b4-cj
      END IF

      IF (ires.eq.3) THEN
        WRITE (*,*) 'Should be no call to SDASSF3 with IRES = 3.'
      END IF

      IF (ires.eq.4) THEN
        WRITE (*,*) 'Should be no call to SDASSF3 with IRES = 4.'
      END IF
C This is df/dy' for the starting procedure.  This
C problem is a linear ODE of index 0.  So only IRES=1,6 occur.
      IF (ires.eq.7) THEN
        DO 10 i=1,4
          d(i,i)=-1.e0
   10   CONTINUE
        RETURN
      END IF
      END


program vector_1
  use worker_module
  use iso_fortran_env, only : real64
  implicit none

  integer, parameter :: n = 1000000
  integer :: i,k = 1
  real(real64),dimension(n) :: a, b, c, d
  real(real64) :: tmp, pi

  d = (/ (i, i = 1, n ) /)

  do i = 1, n
     c(i) = my_scalar_add(a(i),b(i))
  end do

  do i = 1, n
     c(i) = my_scalar_add_pure(a(i),b(i))
  end do

  do i = 1, n
     call my_scalar_add_elemental_value(c(i), a(i), b(i))
  end do

  do i = 1, n
     c(i) = my_scalar_add_elemental(a(i),b(i))
  end do

  pi = 3.1415_real64
  tmp = 1.0

  do i = 1, n
     c(i) = my_scalar_add_elemental(pi,tmp)
  end do

  c = my_scalar_add_elemental(a(i),b(i))

!DIR$ FORCEINLINE
  do i = 1, n
     c(i) = nice_function_pure(pi,tmp)
  end do

  do i = 1, n
     c(i) = my_scalar_add_omp(pi,tmp)
  end do

contains

  pure function nice_function_pure(x1, x2) result(res)
    implicit none
    real(real64),intent(in) :: x1, x2
    real(real64) :: res

    res = x1 + x2

  end function nice_function_pure

end program vector_1


C     ----------------------------------------------------------------
C     $Revision: 4074 $
C     $Date: 2014-04-23 14:13:52 -0700 (Wed, 23 Apr 2014) $
C     ----------------------------------------------------------------
C     FCVODE Example Problem: Robertson kinetics, Lapack linear solver
C                             with dense user Jacobian.
C
C     The following is a simple example problem, with the coding
C     needed for its solution by CVODE. The problem is from chemical
C     kinetics, and consists of the following three rate equations:
C
C     dy1/dt = -.04*y1 + 1.e4*y2*y3
C     dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2
C     dy3/dt = 3.e7*y2**2
C
C     on the interval from t = 0.0 to t = 4.e10, with initial
C     conditions:
C
C     y1 = 1.0, y2 = y3 = 0.
C
C     The problem is stiff. While integrating the system, we also
C     employ the root finding feature to find the points at which
C     y1 = 1.e-4 or at which y3 = 0.01. The following coding solves
C     this problem with CVODE, using the Fortran/C interface routine
C     package. This solution uses the BDF method and a user-supplied
C     Jacobian routine, and prints results at t = .4, 4., ..., 4.e10.
C     It uses ITOL = 2 and ATOL much smaller for y2 than y1 or y3
C     because y2 has much smaller values. At the end of the run,
C     various counters of interest are printed.
C     ----------------------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER IER, I
      INTEGER LNST, LNFE, LNSETUP, LNNI, LNCF, LNETF, LNJE, LNGE
      INTEGER METH, ITMETH, ITOL, ITASK, JOUT, NOUT, IERROOT
      INTEGER INFO(2)
C The following declaration specification should match C type long int.
      INTEGER*8 NEQ, IOUT(25), IPAR
C The following declaration specification should match C type int.
      INTEGER*4 NEQL
      DOUBLE PRECISION RTOL, T, T0, TOUT
      DOUBLE PRECISION Y(3), ATOL(3), ROUT(10), RPAR
C
      DATA LNST/3/, LNFE/4/, LNETF/5/,  LNCF/6/, LNNI/7/, LNSETUP/8/,
     1     LNGE/12/, LNJE/17/
C
      NEQ = 3
      NEQL = NEQ
      T0 = 0.0D0
      Y(1) = 1.0D0
      Y(2) = 0.0D0
      Y(3) = 0.0D0
      METH = 2
      ITMETH = 2
      ITOL = 2
      RTOL = 1.0D-4
      ATOL(1) = 1.0D-8
      ATOL(2) = 1.0D-14
      ATOL(3) = 1.0D-6
      TOUT = 0.4D0
      ITASK = 1
      JOUT = 0
      NOUT = 12
C
      WRITE(6,10) NEQ
 10   FORMAT('Dense example problem:'//
     1       ' Robertson kinetics, NEQ = ', I2//)
C
      CALL FNVINITS(1, NEQ, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,20) IER
 20     FORMAT(///' SUNDIALS_ERROR: FNVINITS returned IER = ', I5)
        STOP
      ENDIF
C

      CALL FCVMALLOC(T0, Y, METH, ITMETH, ITOL, RTOL, ATOL,
     1               IOUT, ROUT, IPAR, RPAR, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,30) IER
 30     FORMAT(///' SUNDIALS_ERROR: FCVMALLOC returned IER = ', I5)
        STOP
      ENDIF
C

      CALL FCVROOTINIT(2, IER)
      IF (IER .NE. 0) THEN
         WRITE(6,45) IER
 45      FORMAT(///' SUNDIALS_ERROR: FCVROOTINIT returned IER = ', I5)
         CALL FCVFREE
         STOP
      ENDIF
C
      CALL FCVLAPACKDENSE(NEQL, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,40) IER
 40     FORMAT(///' SUNDIALS_ERROR: FCVLAPACKDENSE returned IER = ', I5)
        CALL FCVFREE
        STOP
      ENDIF
C
      CALL FCVLAPACKDENSESETJAC(1, IER)
C
      DO WHILE(JOUT .LT. NOUT)
C
        CALL FCVODE(TOUT, T, Y, ITASK, IER)
C
        WRITE(6,50) T, Y(1), Y(2), Y(3)
 50     FORMAT('At t = ', E12.4, '   y = ', 3E14.6)
C
        IF (IER .LT. 0) THEN
           WRITE(6,60) IER, IOUT(15)
 60        FORMAT(///' SUNDIALS_ERROR: FCVODE returned IER = ', I5, /,
     1            '                 Linear Solver returned IER = ', I5)
           CALL FCVROOTFREE
           CALL FCVFREE
           STOP
        ENDIF
C
        IF (IER .EQ. 2) THEN
           CALL FCVROOTINFO(2, INFO, IERROOT)
           IF (IERROOT .LT. 0) THEN
              WRITE(6,65) IER
 65           FORMAT(///' SUNDIALS_ERROR: FCVROOTINFO returned IER = ',
     1              I5)
              CALL FCVROOTFREE
              CALL FCVFREE
              STOP
           ENDIF
           WRITE(6,70) (INFO(I), I = 1, 2)
 70        FORMAT(5X, 'Above is a root, INFO() = ', 2I3)
        ENDIF
C
        IF (IER .EQ. 0) THEN
           TOUT = TOUT * 10.0D0
           JOUT = JOUT + 1
        ENDIF
C
      ENDDO
C
      CALL FCVDKY(T, 1, Y, IER)
      IF (IER .NE. 0) THEN
         WRITE(6,80) IER
 80      FORMAT(///' SUNDIALS_ERROR: FCVDKY returned IER = ', I4)
         CALL FCVROOTFREE
         CALL FCVFREE
         STOP
      ENDIF
      WRITE(6,85) Y(1), Y(2), Y(3)
 85   FORMAT(/'Final value of ydot = ', 3E14.6)
C
      WRITE(6,90) IOUT(LNST), IOUT(LNFE), IOUT(LNJE), IOUT(LNSETUP),
     1            IOUT(LNNI), IOUT(LNCF), IOUT(LNETF), IOUT(LNGE)
 90   FORMAT(//'Final statistics:'//
     1       ' No. steps = ', I4, '   No. f-s = ', I4,
     2       '   No. J-s = ', I4, '   No. LU-s = ', I4/
     3       ' No. nonlinear iterations = ', I4/
     4       ' No. nonlinear convergence failures = ', I4/
     5       ' No. error test failures = ', I4/
     6       ' No. root function evals = ', I4)
C
      CALL FCVROOTFREE
      CALL FCVFREE
C
      STOP
      END

C     ----------------------------------------------------------------

      SUBROUTINE FCVFUN(T, Y, YDOT, IPAR, RPAR, IER)
C Fortran routine for right-hand side function.
      IMPLICIT NONE
C
C The following declaration specification should match C type long int.
      INTEGER*8 IPAR(*)
      INTEGER IER
      DOUBLE PRECISION T, Y(*), YDOT(*), RPAR(*)
C
      YDOT(1) = -0.04D0 * Y(1) + 1.0D4 * Y(2) * Y(3)
      YDOT(3) = 3.0D7 * Y(2) * Y(2)
      YDOT(2) = -YDOT(1) - YDOT(3)
C
      IER = 0
C
      RETURN
      END

C     ----------------------------------------------------------------

      SUBROUTINE FCVROOTFN(T, Y, G, IPAR, RPAR, IER)
C Fortran routine for root finding
      IMPLICIT NONE
C
      DOUBLE PRECISION T, Y(*), G(*), RPAR(*)
C The following declaration specification should match C type long int.
      INTEGER*8 IPAR(*)
      INTEGER IER
C
      G(1) = Y(1) - 1.0D-4
      G(2) = Y(3) - 1.0D-2
C
      IER = 0

      RETURN
      END

C     ----------------------------------------------------------------

      SUBROUTINE FCVDJAC(N, T, Y, FY, JAC, H, IPAR, RPAR,
     1                   V1, V2, V3, IER)
C Fortran routine for dense user-supplied Jacobian.
      IMPLICIT NONE
C
C The following declaration specification should match C type long int.
      INTEGER*8 N, IPAR(*)
      INTEGER IER
      DOUBLE PRECISION T, Y(*), FY(*), JAC(N,*), H, RPAR(*)
      DOUBLE PRECISION V1(*), V2(*), V3(*)
C
      DOUBLE PRECISION  Y1, Y2, Y3
C
      Y1 = Y(1)
      Y2 = Y(2)
      Y3 = Y(3)
      JAC(1,1) = -0.04D0
      JAC(1,2) = 1.0D4 * Y3
      JAC(1,3) = 1.0D4 * Y2
      JAC(2,1) =  0.04D0
      JAC(2,2) = -1.0D4 * Y3 - 6.0D7 * Y2
      JAC(2,3) = -1.0D4 * Y2
      JAC(3,3) = 0.0D0
      JAC(3,2) = 6.0D7 * Y2
      JAC(3,3) = 0.0D0
C
      IER = 0
C
      RETURN
      END


! { dg-do run }
! Tests the fix for the bug PR40629, in which the reference to 'x'
! in 'upper' wrongly host-associated with the symbol 'x' at module
! leve rather than the function.
!
! Contributed by Philippe Marguinaud  <philippe.marguinaud@meteo.fr>
!
MODULE m
  REAL :: x = 0
CONTAINS
  subroutine s
    call upper
    call lower
  CONTAINS
    SUBROUTINE upper
     y = x(3,1)
     if (int(y) .ne. 3) call abort
    END SUBROUTINE
    FUNCTION x(n, m)
       x = m*n
    END FUNCTION
    SUBROUTINE lower
     y = x(2,1)
     if (int(y) .ne. 2) call abort
    END SUBROUTINE
  END SUBROUTINE
END MODULE

  use m
  call s
end
! { dg-final { cleanup-modules "m" } }


program tstBLAS

integer              :: n
real                 :: a
real,dimension(1000) :: x,y
integer              :: i
real                 :: expected
integer              :: incx,incy

!set up some data
n=300
do i=1,n
    x(i)=real(i)
    y(i)=real(i)**2
end do

!calculate y = a*x + y
a=7.0
incx=1
incy=1
call saxpy( n, a, x, incx, y, incy )

do i=1,n
    expected = 7.0*real(i) + real(i)**2
    if( abs( y(i)/expected - 1 )>1e-4 )then
        write(*,*)'error matching element i=',i,' expected=',expected,' received=',y(i)
        stop
    end if
end do

end program


      double precision function psi(xc,yc)
      implicit none

      double precision xc, yc
      double precision revs_per_s,u0, v0

      double precision u0_comm,v0_comm, revs_comm
      common /comm_velocity/ u0_comm,v0_comm,revs_comm

      revs_per_s = revs_comm
      u0 = u0_comm
      v0 = v0_comm

      psi = -revs_per_s*(u0*xc - v0*yc)

      end