subroutine interplandm (plono, nlato, nlono, lato, rlono, &
                        landmfile, landmo)
!
! Read LANDM_COSLAT from input file and interpolate to output grid.
! The input grid is assumed rectangular, but the output grid may
! be reduced.
!
  use shr_kind_mod, only: r8 => shr_kind_r8

  implicit none

  include 'netcdf.inc'
!
! Input arguments
!
  integer , intent(in) :: plono                ! output longitude dimension
  integer , intent(in) :: nlato                ! number of latitudes
  integer , intent(in) :: nlono(nlato)         ! number of reduced latitudes
  real(r8), intent(in) :: lato(nlato)          ! latitude at center of grid cell
  real(r8), intent(in) :: rlono(plono,nlato)   ! longitude on (potentially reduced) output grid
  character(len=*), intent(in) :: landmfile    ! file containing input LANDM_COSLAT
!
! Output arguments
!
  real(r8), intent(out) :: landmo(plono,nlato) ! landm on reduced grid

! Local variables

  integer :: nloni
  integer :: nlati
  integer :: i,j                    ! spatial indices
  integer :: ret                    ! return code

  integer :: landmfileid                     ! netcdf file id for landm file
  integer :: londimid, latdimid              ! lon, lat dimension ids
  integer :: lonid, latid                    ! lon, lat var ids
  integer :: landmid                         ! landm variable id

  real(r8), allocatable :: landmi(:,:)       ! landm on full grid
  real(r8), allocatable :: lati(:)
  real(r8), allocatable :: loni(:)
  real(r8), allocatable :: xtemp(:,:)        ! temporary for interpolation

  ret = nf_open (landmfile, nf_nowrite, landmfileid)
  if (ret /= nf_noerr) then
     write(6,*)nf_strerror(ret)
     write(6,*)'Unable to open input file ', trim (landmfile)
     stop 999
  end if
!
! Retrieve grid info and LANDM_COSLAT field from from offline file.
!
  call wrap_inq_dimid (landmfileid, 'lat', latdimid)
  call wrap_inq_dimlen (landmfileid, latdimid, nlati)

  call wrap_inq_dimid (landmfileid, 'lon', londimid)
  call wrap_inq_dimlen (landmfileid, londimid, nloni)

  allocate (lati(nlati))
  allocate (loni(nloni))
  allocate (landmi(nloni,nlati))

  call wrap_inq_varid (landmfileid, 'lat', latid)
  call wrap_get_var8 (landmfileid, latid, lati)

  call wrap_inq_varid (landmfileid, 'lon', lonid)
  call wrap_get_var8 (landmfileid, lonid, loni)

  call wrap_inq_varid (landmfileid, 'LANDM_COSLAT', landmid)
  call wrap_get_var8 (landmfileid, landmid, landmi)

  allocate (xtemp(nloni,nlato))
!
! For rectangular -> reduced, interpolate first in latitude, then longitude
!
  do i=1,nloni
     call lininterp (landmi(i,1), nlati, nloni, lati, &
                     xtemp(i,1), nlato, nloni, lato, .false.)
  end do

  do j=1,nlato
    call lininterp (xtemp(1,j), nloni, 1, loni, &
                    landmo(1,j), nlono(j), 1, rlono(1,j), .true.)
  end do

  deallocate (xtemp)
  deallocate (lati)
  deallocate (loni)
  deallocate (landmi)

  return
end subroutine interplandm


      SUBROUTINE STR_FORMAT_RANGE
     &          (minv,maxv,incv,frmt)

c***********************************************************************
c                   subroutine str_format_range
c***********************************************************************
c
c  Program Source:  Naval Ocean Systems Center - Code 542
c
c  Date:
c     28 Dec 1994
c
c  Function:
c     Creates a format specification for listing a range of numbers
c     given the minimum, maximum and increment.  The output string
c     is restricted to '(f99.97)'
c
c  Parameters passed:
c     parameter-name [t,n] description {t is type, n is dimension}
c     minv           [r]   minimum   value
c     maxv           [r]   maximum   value
c     incv           [r]   increment value
c
c  Parameters returned:
c     parameter-name [t,n] description {t is type, n is dimension}
c     frmt           [s]   format specification
c
c  Common blocks referenced:
c
c  Functions and subroutines referenced:
c
c  References:
c
c  Change History:
c
c*******************!***************************************************

      character*(*) frmt
      character* 80 test
      logical       loop
      integer       nd
      integer       nrdecimals
      integer       nrdigits
      real          minv,maxv,incv

c     Number of digits in front of the decimal point
      if (minv .eq. 0.) then
         nrdigits=INT(LOG10(ABS(maxv)))+1
      else
     &if (maxv .eq. 0.) then
         nrdigits=INT(LOG10(ABS(minv)))+1
         if (minv .lt. 0.) nrdigits=nrdigits+1
      else
         nrdigits=INT(MAX(LOG10(ABS(minv)),LOG10(ABS(maxv))))+1
         if (minv .lt. 0.) nrdigits=nrdigits+1
      end if

c     Check if the increment has a fraction
      if (incv-INT(incv) .ne. 0.) then
         loop=.true.
         nd=1
         do while (loop)
            if (nd .lt. 10) then
               write(frmt,
     &             '(''(f'',i2,''.'',i1,'')'')') nrdigits+1+nd,nd
            else
               write(frmt,
     &             '(''(f'',i2,''.'',i2,'')'')') nrdigits+1+nd,nd
            end if
            write(test,frmt) incv
            if (test(nrdigits+1+nd:nrdigits+1+nd) .eq. '0') then
               nd=nd+1
            else
               loop=.false.
            end if
         end do
         loop=.true.
         do while (loop)
            if (nd .lt. 10) then
               write(frmt,
     &             '(''(f'',i2,''.'',i1,'')'')') nrdigits+1+nd,nd
            else
               write(frmt,
     &             '(''(f'',i2,''.'',i2,'')'')') nrdigits+1+nd,nd
            end if
            write(test,frmt) incv
            if (test(nrdigits+1+nd:nrdigits+1+nd) .eq. '0') then
               loop=.false.
            else
               nd=nd+1
            end if
         end do
         nrdecimals=nd-1
      else

c        Output is whole numbers
         nrdecimals=0
      end if

c     Write the format specification
      if (nrdecimals .eq. 0) then
         if (nrdigits .lt. 10) then
            write(frmt,
     &          '(''(f'',i1,''.0)'')') nrdigits+2
         else
            write(frmt,
     &          '(''(f'',i2,''.0)'')') nrdigits+2
         end if
      else
         nrdigits=nrdigits+1+nrdecimals
         if (nrdigits .lt. 10) then
            write(frmt,
     &          '(''(f'',i1,''.'',i1,'')'')') nrdigits,nrdecimals
         else
            if (nrdecimals .lt. 10) then
               write(frmt,
     &             '(''(f'',i2,''.'',i1,'')'')') nrdigits,nrdecimals
            else
               write(frmt,
     &             '(''(f'',i2,''.'',i2,'')'')') nrdigits,nrdecimals
            end if
         end if
      end if
      RETURN
      END      ! STR_FORMAT_RANGE


module colours
	use, intrinsic :: ISO_C_BINDING

	implicit none

	! this type represents an RGB colour
	type, bind(C) :: colour
		integer(C_INT) :: r, g, b
	end type

	! parameters: file identifier, and number of colours
	integer, parameter :: fid = 10, n_colours = 360
	! this array will store the colour table
	type(colour), dimension(:), allocatable :: table
	! the name of the csv file containing colour data
	character(*), parameter :: fname = "chelix.csv"

	contains

	subroutine init_colours(max_value) bind(C)
		! load the colours from the file
		implicit none

		! 'max_value' is the largest value in a channel (e.g: 255)
		integer(C_INT), value :: max_value
		! variables for line no. and status
		integer :: index, stat
		! this array will store each line of data
		real, dimension(4) :: vals

		! open the file for reading
		open(fid, file=fname, status="old", action="read")
		allocate(table(n_colours))

		do index=1, n_colours
			! read a line from the file into 'vals'
			read(fid, *, iostat=stat) vals(:)

			if (stat .lt. 0) then
				! status < 0: end of file
				write(*,*) "only", index, "entries read"
				! stop reading
				exit
			else if (stat .gt. 0) then
				! status > 0: some other error
				write(*,*) "error reading ", fname
				! stop reading
				exit
			end if

			! set the entry in the colour table
			table(index)%r = floor(vals(2) * max_value)
			table(index)%g = floor(vals(3) * max_value)
			table(index)%b = floor(vals(4) * max_value)
		end do

		! close the file
		close(fid)
	end subroutine

	type(colour) function get_colour(index) bind(C)
		! returns a colour from the table
		implicit none
		! argument in a C int in range 1:n_colours
		integer(C_INT), value :: index
		! return the requested colour struct
		get_colour = table(index)
	end function

	subroutine cubehelix(start, rots, hue, gamma, nlev, reverse) bind(C)
		integer(C_INT), value :: nlev
		real(C_DOUBLE), value :: start, rots, hue, gamma
		logical(C_BOOL), value :: reverse

		real(8) :: pi, fract, angle, amp, r, g, b
		integer :: i, max_value = 255, index

		pi = 4.0*atan(1.0)

		allocate(table(nlev))

		do i=1, nlev
			fract = float(i-1) / float(nlev-1)
			angle = 2 * pi * (start/3.0 + 1.0 + rots*fract)

			fract = fract ** gamma
			amp = hue * fract * (1 - fract) / 2.0

			r = fract + amp * (-0.14861*cos(angle) + 1.78277*sin(angle))
    	g = fract + amp * (-0.29227*cos(angle) - 0.90649*sin(angle))
    	b = fract + amp * (+1.97294*cos(angle))

    	if (r .lt. 0.0) then
    		r = 0.0
    	else if (r .gt. 1.0) then
    		r = 1.0
    	end if

    	if (g .lt. 0.0) then
    		g = 0.0
    	else if (g .gt. 1.0) then
    		g = 1.0
    	end if

    	if (b .lt. 0.0) then
    		b = 0.0
    	else if (b .gt. 1.0) then
    		b = 1.0
    	end if

			if (reverse) then
				index = nlev - i + 1
			else
				index = i
			end if

    	table(index)%r = floor(r * max_value)
    	table(index)%g = floor(g * max_value)
    	table(index)%b = floor(b * max_value)
    end do

	end subroutine
end module colours


! **********************************************************************************
! *                  ROUTINES FOR COMPUTING MACHINE CONSTANTS                      *
! *    -----------------------------------------------------------------------     *
! *    List of subroutines:                                                        *
! *      DrvParameters,       machr.                                               *
! **********************************************************************************
subroutine DrvParameters
!-----------------------------------------------------------------------------------
! The routine computes the following machine constants:                            !
! - NBaseDig (integer),        NIterBes (integer),         NIterPol (integer),     !
! - LargestPosNumber (real),   SmallestPosNumber (real),   MachEps (real),         !
! - ZeroCoord (real),          TolJ0Val (real),            TolRootPol (real),      !
! - InitBesVal (real),         FactNBes (real),            LargestBesVal (real),   !
! - UpperBoundSeq (real),      LowerBoundSeq (real),       ZeroSinXX (real),       !
! - MaxArgBes (real),          ZeroLUVal (real),           LargestSplineVal (real) !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer  :: ibeta, it, irnd, ngrd, machep, negep, iexp, minexp, maxexp
  real(O)  :: eps, epsneg, xmin, xmax, x, step, fct
!
  call machr ( ibeta, it, irnd, ngrd, machep, negep, iexp, minexp, maxexp,          &
       eps, epsneg, xmin, xmax )
  LargestPosNumber  = xmax
  SmallestPosNumber = xmin
  MachEps  = eps
  NBaseDig = it
  NIterBes = 5000
  NIterPol = 100000
!
  ZeroCoord  = eps**0.666_O
  if (O == kind(1.e0)) then
    fct = 10._O
  else
    fct = 1._O
  end if
  TolJ0Val   = fct * eps**0.666_O
  TolRootPol = eps
  InitBesVal = 1.e-35_O
  FactNBes   = 400._O
  LargestBesVal = xmax**0.333_O
  MaxArgBes     = 1.e+4_O
  UpperBoundSeq = 1.e+10_O
  LowerBoundSeq = 1.e-10_O
  x    = 1._O
  step = 0.5_O
  fct  = sin(x) / x
  do while (fct < 1._O)
    x   = step * x
    fct = sin(x) / x
  end do
  ZeroSinXX = x
  ZeroLUVal = 1.e-20_O
  x = sqrt (xmax)
  LargestSplineVal = sqrt(x)
end subroutine DrvParameters
! **********************************************************************************
subroutine machr ( ibeta, it, irnd, ngrd, machep, negep, iexp, minexp, maxexp,      &
           eps, epsneg, xmin, xmax)
!-----------------------------------------------------------------------------------
! The routine computes the parameters of the floating-point arithmetic system.     !
!                                                                                !
! Output parameters:                                                               !
! - ibeta (integer) - the radix for the floating-point representation.             !
! - it (integer) - the number of base ibeta digits in the floating-point           !
!   significand.                                                                   !
! - irnd (integer) - specifies if floating-point addition chops or rounds          !
!   appear.                                                                        !
! - ngrd (integer) - the number of guard digits for multiplication with            !
!   truncating arithmetic.                                                         !
! - machep (integer) - the largest negative integer such that                      !
!   1.0 + real(ibeta) ** machep /= 1.0.                                            !
! - negeps (integer) - the largest negative integer such that                      !
!   1.0 - real(ibeta) ** negeps /= 1.0.                                            !
! - iexp (integer) - the number of bits reserved for the representation of         !
!   the exponent of a floating-point number.                                       !
! - minexp (integer) - the largest in magnitude negative integer such that         !
!   real(ibeta) ** minexp is positive and normalized.                              !
! - maxexp (integer) - the smallest positive power of beta that overflows.         !
! - eps (real) - the smallest positive floating-point number such that             !
!   1.0 + eps /= 0.0.                                                              !
! - epsneg (real) - the smallest positive floating-point number such that          !
!   1.0 - epsneg /= 0.0.                                                           !
! - xmin (real) - the smallest non-vanishing normalized floating-point power.      !
!   of the radix: xmin = real(ibeta) ** minexp.                                    !
! - xmax (real) - the largest finite floating-point number.                        !
!   xmax = (1.0 - epsneg) * real(ibeta) ** maxexp.                                 !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer  :: ibeta, it, irnd, ngrd, machep, negep, iexp, minexp, maxexp
  real(O)  :: eps, epsneg, xmin, xmax
!
  integer  :: i, itemp, iz, j, k, mx, nxres
  real(O)  :: a, b, beta, betah, betain, oner, t, temp, temp1, tempa, twor,          &
              y, z, zeror
!
  oner  = 1._O
  twor  = oner + oner
  zeror = oner - oner
  a = oner
  do
    a = a + a
    temp  = a + oner
    temp1 = temp - a
    if (temp1 - oner /= zeror ) exit
  end do
  b = oner
  do
    b = b + b
    temp  = a + b
    itemp = int (temp - a)
    if (itemp /= 0) exit
  end do
  ibeta = itemp
  beta  = real(ibeta,O)
  it = 0
  b  = oner
  do
    it = it + 1
    b  = b * beta
    temp  = b + oner
    temp1 = temp - b
    if (temp1 - oner /= zeror) exit
  end do
  irnd  = 0
  betah = beta / twor
  temp  = a + betah
  if (temp - a /= zeror) irnd = 1
  tempa = a + beta
  temp  = tempa + betah
  if (irnd == 0 .and. temp - tempa /= zeror) irnd = 2
  negep  = it +3
  betain = oner / beta
  a = oner
  do i = 1, negep
    a = a * betain
  end do
  b = a
  do
    temp = oner - a
    if (temp - oner /= zeror) exit
    a = a * beta
    negep = negep - 1
  end do
  negep  = - negep
  epsneg = a
  if (ibeta /= 2 .and. irnd /= 0) then
    a = (a * (oner + a)) / twor
    temp = oner - a
    if (temp - oner /= zeror) epsneg = a
  end if
  machep = -it - 3
  a = b
  do
    temp = oner + a
    if (temp - oner /= zeror) exit
    a = a * beta
    machep = machep + 1
  end do
  eps  = a
  temp = tempa + beta * (oner + eps)
  if (ibeta /= 2 .and. irnd /= 0) then
    a = (a * (oner + a)) / twor
    temp = oner + a
    if (temp - oner /= zeror) eps = a
  end if
  ngrd = 0
  temp = oner + eps
  if (irnd == 0 .and. temp * oner - oner /= zeror) ngrd = 1
  i = 0
  k = 1
  z = betain
  t = oner + eps
  nxres = 0
  do
    y = z
    z = y * y
    a = z * oner
    temp = z * t
    if (a + a == zeror .or. abs(z) >= y) exit
    temp1 = temp * betain
    if (temp1 * beta == z) exit
    i = i + 1
    k = k + k
  end do
  if (ibeta /= 10) then
    iexp = i + 1
    mx   = k + k
  else
    iexp = 2
    iz   = ibeta
    do
      if (k < iz) exit
      iz   = iz * ibeta
      iexp = iexp + 1
    end do
    mx = iz + iz - 1
  end if
  do
    xmin = y
    y = y * betain
    a = y * oner
    temp = y * t
    if ( a + a == zeror .or. abs(y) >= xmin) exit
    k = k + 1
    temp1 = temp * betain
    if (temp1 * beta == y) then
      nxres = 3
      xmin  = y
      exit
    end if
  end do
  minexp = - k
  if (mx <= k + k - 3 .and. ibeta /= 10) then
    mx   = mx + mx
    iexp = iexp + 1
  end if
  maxexp = mx + minexp
  irnd   = irnd + nxres
  if (irnd == 2 .or. irnd == 5) maxexp = maxexp - 2
  if (irnd == 3 .or. irnd == 4) maxexp = maxexp - it
  i = maxexp + minexp
  if (ibeta ==2 .and. i == 0) maxexp = maxexp - 1
  if (i > 20) maxexp = maxexp - 1
  if (a /= y) maxexp = maxexp - 2
  xmax = oner - epsneg
  if (xmax * oner /= xmax) xmax = oner - beta * epsneg
  xmax = xmax / ( beta * beta * beta * xmin)
  i = maxexp + minexp + 3
  do j = 1, i
    if (ibeta == 2) then
      xmax = xmax + xmax
    else
      xmax = xmax * beta
    end if
  end do
end subroutine machr


\ snagged from the c function to do the same thing
\ ------------------------------------------------------------------------

\ ------------------------------------------------------------------------
\ reverses all the bits of 32 bit value n1

\ : revbits       ( n1 --- n2 )
\   dup  1 u>> $55555555 and swap  1 << $aaaaaaaa and or
\   dup  2 u>> $33333333 and swap  2 << $cccccccc and or
\   dup  4 u>> $0f0f0f0f and swap  4 << $f0f0f0f0 and or
\   dup  8 u>> $00ff00ff and swap  8 << $ff00ff00 and or
\   dup 16 u>> $0000ffff and swap 16 << $ffff0000 and or ;

\ the above is 313 bytes in x4

\ ------------------------------------------------------------------------
\ this is maybe more obfuscated

\ here
\   $0000ffff , $ffff0000 , $00ff00ff , $ff00ff00 ,
\   $0f0f0f0f , $f0f0f0f0 , $33333333 , $cccccccc ,
\   $55555555 , $aaaaaaaa ,

\ ------------------------------------------------------------------------

\ : revbits
\   1 5
\   for
\     2dup << >r tuck u>> r>
\     r@ 3 << [ swap literal ] +
\     dup @ swap 4+ @
\     rot and -rot and or
\     swap 2*
\   nxt
\   drop ;

\ the above is 189 bytes

\ ------------------------------------------------------------------------
\ this is definatly more obfuscated :P

here
  $00ff w, $ff00 w, $0f0f w, $f0f0 w,
  $3333 w, $cccc w, $5555 w, $aaaa w,

\ ------------------------------------------------------------------------
\ bit reverses w2 exits with w1 on top

here ]      ( w1 w2 --- w2' w1 )
  $40001 split
  for
    2dup u>> >r tuck << r>
    r@ cells [ rot ]# + @ split
    -rot and -rot and or
    swap 2*
  nxt
  drop swap ;

\ ------------------------------------------------------------------------
\ joins the two bit reversed words

here
  ] join ;

\ ------------------------------------------------------------------------
\ bit reverses 32 bit n1

: revbits       ( n1 --- n1' )
  split                 \ split tp w1 and w2
  literal >r            \ set address to rejoin
  literal dup 2>r ;     \ set address to bit reverse w1 and w2

\ the above is 189 bytes too :)

\ ------------------------------------------------------------------------
\ this is alot smaller but not obfuscated :)

\ : revbits  ( n1 --- 0
\  0 32
\  for
\    2*
\    over 1 and +
\    swap 2/ swap
\  nxt nip ;

\ ========================================================================


! { dg-do compile }

! Type-bound procedures
! Check for errors with operator calls.

MODULE m
  IMPLICIT NONE

  TYPE myint
    INTEGER :: value
  CONTAINS
    PROCEDURE, PASS :: add_int
    PROCEDURE, PASS :: assign_int
    GENERIC, PRIVATE :: OPERATOR(.PLUS.) => add_int
    GENERIC, PRIVATE :: OPERATOR(+) => add_int
    GENERIC, PRIVATE :: ASSIGNMENT(=) => assign_int
  END TYPE myint

  TYPE myreal
    REAL :: value
  CONTAINS
    PROCEDURE, PASS :: add_real
    PROCEDURE, PASS :: assign_real
    GENERIC :: OPERATOR(.PLUS.) => add_real
    GENERIC :: OPERATOR(+) => add_real
    GENERIC :: ASSIGNMENT(=) => assign_real
  END TYPE myreal

CONTAINS

  PURE TYPE(myint) FUNCTION add_int (a, b)
    CLASS(myint), INTENT(IN) :: a
    INTEGER, INTENT(IN) :: b
    add_int = myint (a%value + b)
  END FUNCTION add_int

  SUBROUTINE assign_int (dest, from)
    CLASS(myint), INTENT(OUT) :: dest
    INTEGER, INTENT(IN) :: from
    dest%value = from
  END SUBROUTINE assign_int

  TYPE(myreal) FUNCTION add_real (a, b)
    CLASS(myreal), INTENT(IN) :: a
    REAL, INTENT(IN) :: b
    add_real = myreal (a%value + b)
  END FUNCTION add_real

  SUBROUTINE assign_real (dest, from)
    CLASS(myreal), INTENT(OUT) :: dest
    REAL, INTENT(IN) :: from
    dest%value = from
  END SUBROUTINE assign_real

  SUBROUTINE in_module ()
    TYPE(myint) :: x
    x = 0 ! { dg-bogus "Can't convert" }
    x = x + 42 ! { dg-bogus "Operands of" }
    x = x .PLUS. 5 ! { dg-bogus "Unknown operator" }
  END SUBROUTINE in_module

  PURE SUBROUTINE iampure ()
    TYPE(myint) :: x

    x = x + 42 ! { dg-bogus "to a impure procedure" }
    x = x .PLUS. 5 ! { dg-bogus "to a impure procedure" }
  END SUBROUTINE iampure

END MODULE m

PURE SUBROUTINE iampure2 ()
  USE m
  IMPLICIT NONE
  TYPE(myreal) :: x

  x = 0.0 ! { dg-error "is not PURE" }
  x = x + 42.0 ! { dg-error "impure function" }
  x = x .PLUS. 5.0 ! { dg-error "impure function" }
END SUBROUTINE iampure2

PROGRAM main
  USE m
  IMPLICIT NONE
  TYPE(myint) :: x

  x = 0 ! { dg-error "Can't convert" }
  x = x + 42 ! { dg-error "Operands of" }
  x = x .PLUS. 5 ! { dg-error "Unknown operator" }
END PROGRAM main


      PROGRAM MAIN

C*********************************************************************72
C  Advent of Code 2021
C  --- Day 10: Syntax Scoring ---
C
C  data.txt - 90 lines of input, max length is 109
C  example.txt - 10 lines of input, max length is 24

      IMPLICIT NONE

      CHARACTER*128 INF_N! Input file name
      INTEGER INF_H ! Handle for the input file
      CHARACTER*128 LINES(128)
      CHARACTER CSTACK(128)
      INTEGER*8 SCORES(128)
      INTEGER I, J, N, L_LEN, CS_TOP
      INTEGER*8 M, PART_1, PART_2
      PARAMETER (INF_H = 10)

C  Check if the input file name is available - if not, then exit
      I = IARGC()
      IF (I .LT. 1) THEN
          WRITE(*, '(A)') 'ERROR: An input file is required!'
          GOTO 9999
      END IF

C  Read input from data file, stop if end-of-file is reached
      CALL GETARG(1, INF_N)
      OPEN(INF_H, FILE=INF_N, STATUS='OLD')
      I = 0
      N = 0
      DO WHILE (I .EQ. 0)
          N = N + 1
          READ(INF_H, *, IOSTAT=I) LINES(N)
      END DO
      IF (I .NE. 0) THEN ! Decrement line count if there was an error
          N = N - 1
      END IF
      CLOSE(INF_H)

C  Part 1 solution & 2 scores
      PART_1 = 0
      M = 0
      DO I = 1, N
          CS_TOP = 0
          L_LEN = LEN(LINES(I))
          DO J = 1, L_LEN
              IF (LINES(I)(J:J) .EQ. '(' .OR.
     2              LINES(I)(J:J) .EQ. '[' .OR.
     3              LINES(I)(J:J) .EQ. '{' .OR.
     4              LINES(I)(J:J) .EQ. '<') THEN ! Push char to stack
                  CS_TOP = CS_TOP + 1
                  CSTACK(CS_TOP) = LINES(I)(J:J)
              ELSE IF (LINES(I)(J:J) .EQ. ')') THEN
                  IF (CSTACK(CS_TOP) .EQ. '(') THEN
                      CS_TOP = CS_TOP - 1
                  ELSE
                      PART_1 = PART_1 + 3
                      GO TO 10
                  END IF
              ELSE IF (LINES(I)(J:J) .EQ. ']') THEN
                  IF (CSTACK(CS_TOP) .EQ. '[') THEN
                      CS_TOP = CS_TOP - 1
                  ELSE
                      PART_1 = PART_1 + 57
                      GO TO 10
                  END IF
              ELSE IF (LINES(I)(J:J) .EQ. '}') THEN
                  IF (CSTACK(CS_TOP) .EQ. '{') THEN
                      CS_TOP = CS_TOP - 1
                  ELSE
                      PART_1 = PART_1 + 1197
                      GO TO 10
                  END IF
              ELSE IF (LINES(I)(J:J) .EQ. '>') THEN
                  IF (CSTACK(CS_TOP) .EQ. '<') THEN
                      CS_TOP = CS_TOP - 1
                  ELSE
                      PART_1 = PART_1 + 25137
                      GO TO 10
                  END IF
              END IF
          END DO

          PART_2 = 0
          DO J = 0, CS_TOP - 1
              IF (CSTACK(CS_TOP - J) .EQ. '(') THEN
                  PART_2 = (PART_2 * 5) + 1
              ELSE IF (CSTACK(CS_TOP - J) .EQ. '[') THEN
                  PART_2 = (PART_2 * 5) + 2
              ELSE IF (CSTACK(CS_TOP - J) .EQ. '{') THEN
                  PART_2 = (PART_2 * 5) + 3
              ELSE IF (CSTACK(CS_TOP - J) .EQ. '<') THEN
                  PART_2 = (PART_2 * 5) + 4
              END IF
          END DO
          M = M + 1
          SCORES(M) = PART_2
   10 END DO
      WRITE(*, '(A, I10.1)') 'Part 1: ', PART_1

C  Part 2 solution
      CALL ISORT(SCORES, M)
      IF (MOD(M, 2) .EQ. 0) THEN ! Calculate mean value
          PART_2 = (SCORES(M / 2) + SCORES(M / 2 + 1)) / 2
      ELSE
          PART_2 = SCORES((M + 1) / 2)
      END IF

      WRITE(*, '(A, I10.1)') 'Part 2: ', PART_2

 9999 STOP
      END

      SUBROUTINE ISORT(ARR, A_SIZE)

          IMPLICIT NONE

          INTEGER*8 ARR(A_SIZE), A_SIZE, I, J, T

          DO I = 2, A_SIZE
              T = ARR(I)
              J = I
   20         J = J - 1
              IF (J .EQ. 0) GO TO 30
              IF (ARR(J) .LE. T) GO TO 30
              ARR(J + 1) = ARR(J)
              GO TO 20
   30         ARR(J + 1) = T
          END DO
          RETURN
      END


c     program DRSGEFSC
c>> 2001-05-22 DRSGEFSC Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRSGEFSC Krogh Moved format up.
c>> 1994-10-19 DRSGEFSC Krogh  Changes to use M77CON
c>> 1994-08-09 DRSGEFSC WVS removed '0' from format
c>> 1992-03-18 DRSGEFSC CLL Added "c" to "program" line above.
c>> 1987-12-09 DRSGEFSC Lawson  Initial Code.
c--S replaces "?": DR?GEFSC, ?GEFSC, ?GEFS, ?MATP
c
c     Demo driver for SGEFSC
c     ------------------------------------------------------------------
      integer NMAX
      parameter (NMAX = 3)
      real             A(3,3), B(3,1), Z(NMAX), RCOND1
      integer I, J, IPVT(NMAX)
c
      data (A(1,J),J=1,3) / 0.579E0, -.394E0, 0.915E0 /
      data (A(2,J),J=1,3) / -0.795E0, 0.226E0, -0.868E0 /
      data (A(3,J),J=1,3) / 0.141E0, -0.329E0, -0.286E0 /
c
      data (B(I,1),I=1,3) / 5.873E0, -5.324E0, 1.069E0 /
c
 100  format(/' RCOND1 =',F7.4)
c     ------------------------------------------------------------------
      call SMATP(A,NMAX,NMAX,NMAX,'0 A(,) =')
      call SMATP(B,NMAX,NMAX,1,'0 B(,) =')
c
      call SGEFSC(A,NMAX,NMAX,B,NMAX,1,IPVT,RCOND1,Z)
c     call SGEFS(A,NMAX,NMAX,B,NMAX,1,IPVT,INFO)
c
      call SMATP(B,NMAX,NMAX,1,'0 SOLN(,) =')
      print 100, RCOND1
c
      end


program main
use Task
implicit none

     real(8), allocatable, dimension(:,:) :: A
     integer x1, x2, y1, y2, i, j, A_size

     integer ier

     A_size = 1000

     allocate(A(A_size,A_size), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива A'

     call omp_set_num_threads(4)

     !$omp parallel do private(i,j) shared(A,A_size) default(none) schedule(dynamic)

     do i = 1, A_size; do j = 1, A_size

          A(i,j) = i + j

     enddo; enddo

     !$omp end parallel do

     call GetMaxCoordinates(A, x1, y1, x2, y2)

     write(*,'(/,4x,a,i6,/,4x,a,i6,/,4x,a,i6,/,4x,a,i6,/)') 'x1   = ', x1, 'y1   = ', y1, 'x2   = ', x2, 'y2   = ', y2

     deallocate(A)

end


!
! Update
!
! Salva a atividade em um arquivo externo
!
subroutine update(N, Madj, netstate, mat_adj, m, h, Nsteps)

  integer, intent(in)    :: N, Nsteps, m, Madj
  real(8), intent(in)    :: h, mat_adj(N, 0:Madj)
  integer                :: contador, aux, NN, j, jj, p, progressbar, netstate_new(N)
!  real(8)                :: prob, auxp
  integer, intent(inout) :: netstate(N)

  ! External functions
  real(8)                :: getActivity, ran1

  open(unit=1, file="saving", access="append") !action

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Primeira marcacao de atividade
  write(1,*) 0, getActivity(N, netstate)

! Setando o progressbar
  contador = 0
  progressbar = Nsteps/30

!  write(*,"(A)",advance='no') " >> ["

  do j = 1, Nsteps

     do p = 1, N

        ! Neuronio pode ser excitado
        if ( ( netstate(p) .eq. 0 ) .and. ( netstate_new(p) .eq. 0 ) ) then

           ! O estimulo externo pode excitar o neuronio
           if ( ran1() .lt. h ) then
              netstate_new(p) = 1
           end if

        else if ( netstate(p) .eq.  1 ) then

           netstate_new(p) = 2

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           do jj = 1, aux

              idx = int( mat_adj(p,jj) )

              if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0) ) ) then
                 netstate_new( idx ) = 1
              end if

!              write(*,*) jj, aux,  mod( mat_adj(p,jj), 1d0)
!              read(*,*)

           end do

        else

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Atualizando o estado da rede
     netstate = netstate_new

     ! Imprimindo em arquivo a historia
     write(1,*) j, getActivity(N, netstate)

!     CALL progressbar_update(contador, progressbar)

  end do

! Finalizando o contador
!  write(*,"(A)") "]"

  close(1)

end subroutine update

!
! mean_activity
!
! Funcao que retorna a atividade media apos um periodo dado
! de iteracoes
!
real(8) function mean_activity(N, Madj, netstate, mat_adj, m, h, Nsteps) result(media)

  integer, intent(in)    :: N, Nsteps, m, Madj
  real(8), intent(in)    :: h, mat_adj(N, 0:Madj)
  integer, intent(inout) :: netstate(N)
  integer                :: netstate_new(N)

! Indices
  integer                :: j, jj, NN, p, aux, idx
  integer                :: contador, progressbar, chave

! Funcoes externas
  real(8)                :: getActivity, ran1
  logical                :: isDead

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Inicializando a media
  media = 0d0

  do j = 1, Nsteps

     do p = 1, N

        ! Neuronio pode ser excitado
        if ( ( netstate(p) .eq. 0 ) .and. ( netstate_new(p) .eq. 0 ) ) then

           ! O estimulo externo pode excitar o neuronio
           if ( ran1() .lt. h ) then
              netstate_new(p) = 1
           end if

        else if ( netstate(p) .eq.  1 ) then

           ! This was wrong: it don't catch the case where m = 2
           ! netstate_new(p) = 2
           netstate_new(p) = modulo(netstate(p) + 1, m)

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           do jj = 1, aux

              idx = int( mat_adj(p,jj) )

              if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. &
                   ( ran1() .lt. mod( mat_adj(p,jj), 1d0) ) ) then

                 netstate_new( idx ) = 1

              end if

           end do

        else

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Se a rede estiver morta e não houver estimulo externo, não adianta prosseguir.
     if ( isDead(N, netstate_new) .and. ( h .eq. 0d0 ) ) then

        media = media/float(Nsteps)

        return
     end if

     ! Atualizando o estado da rede
     netstate = netstate_new

     ! Imprimindo em arquivo a historia
     media = media + getActivity(N, netstate)

     if ( .FALSE. ) then
        open(unit=27, file="activity.data", access="append")
        write(27,*) 'Iteracao: ', j
        do jj = 1, N
           if ( netstate(jj) .eq. 1 ) then
              write(27,*) jj
           endif
        enddo
        write(27,*) 'fim'
        write(27,*)

        close(27)
     end if

  end do

  media = media/float(Nsteps)

  return
end function mean_activity

!
! mean_activity -- OLD
!
! Funcao que retorna a atividade media apos um periodo dado
! de iteracoes
!
real(8) function mean_activity_old(N, Madj, netstate, mat_adj, m, h, Nsteps) result(media)

  integer, intent(in)    :: N, Nsteps, m, Madj
  real(8), intent(in)    :: h, mat_adj(N, 0:Madj)
  integer                :: contador, aux, NN, j, jj, p, progressbar, netstate_new(N)
!  real(8)                :: prob, auxp
  integer, intent(inout) :: netstate(N)
  real(8)                :: getActivity, ran1

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Inicializando a media
  media = 0d0

  do j = 1, Nsteps

     do p = 1, N

        ! Neuronio pode ser excitado
        if ( netstate(p) .eq. 0 ) then

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           ! O estimulo externo pode excitar o neuronio
           if ( ran1() .lt. h ) then

              netstate_new(p) = 1

           ! Ou seus vizinhos podem excita-lo...
           else

              do jj = 1, aux
                 if ( ( netstate(int( mat_adj(p,jj) )) .eq. 1 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then
                    netstate_new(p) = 1
                 end if
              end do

           end if

        else

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Atualizando o estado da rede
     netstate = netstate_new

     ! Imprimindo em arquivo a historia
     media = media + getActivity(N, netstate)

  end do

  media = media/float(Nsteps)

end function mean_activity_old

!
! probabilities
!
! Retorna as probabilidades marginais de neuronios estarem excitados
!
subroutine probabilities(N, Madj, netstate, mat_adj, m, h, Nsteps, probab)

  integer, intent(in)    :: N, Nsteps, m, Madj
  real(8), intent(in)    :: h, mat_adj(N, 0:Madj)
  integer                :: contador, aux, NN, j, jj, p, progressbar, netstate_new(N)
  integer, intent(inout) :: netstate(N)
  real(8), external      :: getActivity, ran1
  real(8), intent(inout) :: probab(N)

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Inicializando o vetor de probabilidades
  do j = 1,N
     probab(j) = 0d0
  end do

! Setando o progressbar
  contador = 0
  progressbar = Nsteps/30

  write(*,"(A)",advance='no') " >> ["

! Realizando o experimento
  do j = 1, Nsteps

     do p = 1, N

        ! Neuronio pode ser excitado
        if ( netstate(p) .eq. 0 ) then

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           do jj = 1, aux
              if ( ( netstate(int( mat_adj(p,jj) )) .eq. 1 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then
                 netstate_new(p) = 1
              end if
           end do

        else

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Atualizando o estado da rede
     netstate = netstate_new

     CALL progressbar_update(contador, progressbar)

  end do

! Normalizando as probabilidades calculadas
  do j = 1,N
     probab(j) = probab(j)/dfloat(Nsteps)
  end do

! Finalizando o contador
  write(*,"(A)") "]"

  return
end subroutine probabilities

!
! death_time
!
! Retorna o tempo em que a rede parou de funcionar sem um
! estimulo externo
!
integer function death_time(N, Madj, netstate, mat_adj, m, Nsteps_max) result(dt)

  integer, intent(in)    :: N, Nsteps_max, m, Madj
  real(8), intent(in)    :: mat_adj(N, 0:Madj)
  integer                :: contador, aux, NN, j, jj, p, progressbar, netstate_new(N), idx
  integer, intent(inout) :: netstate(N)
  logical                :: condicao

  ! funcoes
  real(8)                :: ran1, getActivity
  logical                :: isDead

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

  j = 0

  do while (j .lt. Nsteps_max)

     j = j + 1

     do p = 1, N

        if ( netstate(p) .eq. 1 ) then

           ! Atualizando o proprio neuronio
           netstate_new(p) = 2

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           do jj = 1, aux

              ! Indice para nao ficar acessando desnecessariamente mat_adj
              idx = int( mat_adj(p,jj) )

              if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then

                 netstate_new(idx) = 1

              end if
           end do

        else if ( netstate(p) .gt. 1 ) then

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Testa se a rede jah morreu
     if ( isDead(N, netstate_new) ) then
        dt = j
        return
     end if

     ! Atualizando o estado da rede
     netstate = netstate_new

  end do

  dt = Nsteps_max

  return
end function death_time

!
! death_time
!
! Retorna o tempo em que a rede parou de funcionar sem um
! estimulo externo
!
subroutine death_time_subsampling(N, Madj, netstate, mat_adj, m, Nsteps_max, nume, ElectrodeIndex, outputfile)

  character(len=100)     :: outputfile
  integer, intent(in)    :: N, Nsteps_max, m, Madj, nume
  real(8), intent(in)    :: mat_adj(N, 0:Madj)
  integer                :: contador, aux, NN, j, jj, p, progressbar, netstate_new(N), idx
  integer, intent(inout) :: netstate(N), ElectrodeIndex(nume)
  logical                :: condicao, Teste_Are_ElecDead, new_av_started

  ! funcoes
  real(8)                :: ran1, getActivity
  logical                :: isDead, isDead_subsampling

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Arquivo para escrever os resulstados
  open(unit=27, file=outputfile, access="append")

! Iniciando as variaveis que contam o numero de geracoes
! passadas depois do primeiro seed
  j = 0

! jrel conta o numero de novas geracoes desde a ultima avalanche
  jrel = j

! O seed eh colocado em um dos neuronios avistados por um eletrodo,
! caso contrario nao teria se iniciado avalanche nenhuma.
  new_av_started = .true.

  do while (j .lt. Nsteps_max)

     j = j + 1

     do p = 1, N

        if ( netstate(p) .eq. 1 ) then

           ! Atualizando o proprio neuronio
           netstate_new(p) = 2

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           if ( aux .gt. 0 ) then

              do jj = 1, aux

                 ! Indice para nao ficar acessando desnecessariamente mat_adj
                 idx = int( mat_adj(p,jj) )

                 if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then

                    netstate_new(idx) = 1

                 end if
              end do
           end if

        else if ( netstate(p) .gt. 1 ) then

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Teste nos eletrodos

     ! Pode acontecer de uma avalanche terminar (para os eletrodos) e haver um
     ! espaço de tempo em que nenhum eletrodo sente potencial. Por isso, eh
     ! necessario testar se uma nova avalanche, para os eletrodos, jah se iniciou
     ! antes de marcar mais tempos. Isso eh feito via chaveamento da variavel
     ! logica new_av_started.

     ! Para nao realizar a mesma conta duas vezes:
     Teste_Are_ElecDead = isDead_subsampling(N, netstate_new, nume, ElectrodeIndex)

     ! Testa se hah algum eletrodo ativo
     if ( Teste_Are_ElecDead .and. new_av_started ) then

        write(27,*) j - jrel
        jrel = j

        new_av_started = .false.

     end if

     ! Se nao houver nenhum ativo, testa se uma nova avalanche (para eletrodos)
     ! se iniciou.
     if ( .not. new_av_started ) then
        new_av_started = .not. Teste_Are_ElecDead
     end if

     ! Testa se a rede jah morreu
     ! Testamos se a rede morre apenas no final porque pode ser que a rede morra sem
     ! que os eletrodos sejam excitados em suas ultimas excitacoes.
     if ( isDead(N, netstate_new) ) then

        return

     end if

     ! Em caso de continuacao do algoritmo, atualizando o estado da rede
     netstate = netstate_new

  end do

  close(27)

  return
end subroutine death_time_subsampling

!
! death_time
!
! Retorna o tempo em que a rede parou de funcionar sem um
! estimulo externo
!
subroutine death_time_loose(N, Madj, netstate, mat_adj, m, Nsteps_max, outputfile, pl)

  character(len=100)     :: outputfile
  integer, intent(in)    :: N, Nsteps_max, m, Madj
  real(8), intent(in)    :: mat_adj(N, 0:Madj), pl
  integer                :: contador, aux, NN, j, jj, p, progressbar, netstate_new(N), idx
  integer, intent(inout) :: netstate(N)
  logical                :: condicao, Teste_Are_ElecDead, new_av_started

  ! funcoes
  real(8)                :: ran1, getActivity
  logical                :: isDead, isDead_loose

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Arquivo para escrever os resulstados
  open(unit=27, file=outputfile, access="append")

! Iniciando as variaveis que contam o numero de geracoes
! passadas depois do primeiro seed
  j = 0

! jrel conta o numero de novas geracoes desde a ultima avalanche
  jrel = j

! O seed eh colocado em um dos neuronios avistados por um eletrodo,
! caso contrario nao teria se iniciado avalanche nenhuma.
  new_av_started = .true.

  do while (j .lt. Nsteps_max)

     j = j + 1

     do p = 1, N

        if ( netstate(p) .eq. 1 ) then

           ! Atualizando o proprio neuronio
           netstate_new(p) = 2

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           if ( aux .gt. 0 ) then

              do jj = 1, aux

                 ! Indice para nao ficar acessando desnecessariamente mat_adj
                 idx = int( mat_adj(p,jj) )

                 if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then

                    netstate_new(idx) = 1

                 end if
              end do
           end if

        else if ( netstate(p) .gt. 1 ) then

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Teste nos eletrodos

     ! Pode acontecer de uma avalanche terminar (para os eletrodos) e haver um
     ! espaço de tempo em que nenhum eletrodo sente potencial. Por isso, eh
     ! necessario testar se uma nova avalanche, para os eletrodos, jah se iniciou
     ! antes de marcar mais tempos. Isso eh feito via chaveamento da variavel
     ! logica new_av_started.

     ! Para nao realizar a mesma conta duas vezes:
     Teste_Are_ElecDead = isDead_loose(N, netstate_new, pl)

     ! Testa se hah algum eletrodo ativo
     if ( Teste_Are_ElecDead .and. new_av_started ) then

        write(27,*) j - jrel
        jrel = j

        new_av_started = .false.

     end if

     ! Se nao houver nenhum ativo, testa se uma nova avalanche (para eletrodos)
     ! se iniciou.
     if ( .not. new_av_started ) then
        new_av_started = .not. Teste_Are_ElecDead
     end if

     ! Testa se a rede jah morreu
     ! Testamos se a rede morre apenas no final porque pode ser que a rede morra sem
     ! que os eletrodos sejam excitados em suas ultimas excitacoes.
     if ( isDead(N, netstate_new) ) then

        return

     end if

     ! Em caso de continuacao do algoritmo, atualizando o estado da rede
     netstate = netstate_new

  end do

  close(27)

  return
end subroutine death_time_loose

!
! Avalanche duration usando mesma tecnica que Beggs e Plenz
!
! Esta rotina foi completamente baseada na versão final de death_time_subsampling, mas
! com detalhes um pouco mais realisticos se comparados ao experimento de Beggs e Plenz.
! Em vez de ficar observando quando a avalanche morre segundo o eletrodo, nos integraremos
! a atividade em um intervalo dt. De dt em dt, verificaremos a morte da avalanche.
!
! O valor original de dt nos trabalhos de Beggs e Plenz eh 4 ms.
!
subroutine death_time_BeggsPlenz(N, Madj, netstate, mat_adj, m, Nsteps_max, dt, nume, ElectrodeIndex, outputfile)

  character(len=100)     :: outputfile
  integer, intent(in)    :: N, Nsteps_max, m, Madj, nume, dt
  real(8), intent(in)    :: mat_adj(N, 0:Madj)
  integer                :: NN, progressbar, netstate_new(N)
  integer, intent(inout) :: netstate(N), ElectrodeIndex(nume)
  logical                :: condicao, Teste_Are_ElecDead, new_av_started,  atLeastOneBinAlive

  ! Indices
  integer                :: j, jj, p, jrel, idx, aux, jaux, j0
  integer                :: contador

  ! funcoes
  real(8)                :: ran1, getActivity, getActivity_subsampling
  logical                :: isDead, isDead_subsampling

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Arquivo para escrever os resulstados
  open(unit=27, file=outputfile, access="append")

! Iniciando as variaveis que contam o numero de geracoes
! passadas depois do primeiro seed
  j = 0

! jrel conta o numero de novas geracoes desde a ultima avalanche
  jrel = 2

! jrel comeca com este valor para que a contagem do numero de dts
! em que houve uma avalanche (nos eletrodos) estar correta.

! O seed eh colocado em um dos neuronios avistados por um eletrodo,
! caso contrario nao teria se iniciado avalanche nenhuma.
  new_av_started = .true.

! Dah conta de incluir a primeira excitacao no primeiro bin
  j0 = 2

  do while (j .lt. Nsteps_max)

     ! Atualizando o tempo da simulacao
     j = j + dt

     ! A menos que ao menos um eletrodo se ascenda durante as dt
     ! proximas evolucoes temporais, serah dado como a nenhuma atividade
     ! Por isso, setamos inicialmente a variavel como falsa.
     atLeastOneBinAlive = .false.

     ! Realiza dt evolucoes temporais
     ! sem se preocupar se a rede morre ou nao.
     do jaux = j0, dt

        do p = 1, N

           if ( netstate(p) .eq. 1 ) then

              ! Atualizando o proprio neuronio
              netstate_new(p) = 2

              ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
              aux = int( mat_adj(p, 0) )

              if ( aux .gt. 0 ) then

                 do jj = 1, aux

                    ! Indice para nao ficar acessando desnecessariamente mat_adj
                    idx = int( mat_adj(p,jj) )

                    if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then

                       netstate_new(idx) = 1

                    end if
                 end do
              end if

           else if ( netstate(p) .gt. 1 ) then

              netstate_new(p) = modulo(netstate(p) + 1, m)

           end if

        end do

        ! Testando se os eletrodos estao ativos nesta rodada
        if ( .not. isDead_subsampling(N, netstate_new, nume, ElectrodeIndex) ) then
           atLeastOneBinAlive = .true.
        end if

        ! Atualizando o estado da rede
        netstate = netstate_new

!        write(*,*) j, jrel, &
!             ' | Electrodes alive: ', .not. isDead_subsampling(N, netstate_new, nume, ElectrodeIndex), &
!             'Network alive: ', .not. isDead(N, netstate_new)

     end do
!     read(*,*)

     ! Teste nos eletrodos

     ! Pode acontecer de uma avalanche terminar (para os eletrodos) e haver um
     ! espaço de tempo em que nenhum eletrodo sente potencial. Por isso, eh
     ! necessario testar se uma nova avalanche, para os eletrodos, jah se iniciou
     ! antes de marcar mais tempos. Isso eh feito via chaveamento da variavel
     ! logica new_av_started.

     ! Se uma avalanche nao estiver correndo, marca como uma nova avalanche encontrada
     if ( .not. new_av_started ) then
!        new_av_started = .not. isDead_subsampling(N, netstate_new, nume, ElectrodeIndex)
        new_av_started = atLeastOneBinAlive
        jrel = j
     end if

!    write(*,*) 'Avalanche ocurring: ', new_av_started

     ! Testa durante os ultimos dt tempos nem mesmo um eletrodo foi ativado
     if ( ( .not. atLeastOneBinAlive ) .and. new_av_started ) then

        ! Imprimindo o tamanho da ultima avalanche
        if ( j .eq. 2 ) then
           write(27,*) 2
!           write(*,*) 'Escreveu resultado: ', 2
        else
           write(27,*) j - jrel
!           write(*,*) 'Escreveu resultado: ', j - jrel
        end if

        ! Marcando o termino da ultima avalanche
        new_av_started = .false.

     end if

     ! Testa se a rede jah morreu
     ! Testamos se a rede morre apenas no final porque pode ser que a rede morra sem
     ! que os eletrodos sejam excitados em suas ultimas excitacoes.
     if ( isDead(N, netstate_new) ) then

        ! Pode ocorrer de a rede toda estar morta no ultimo bin temporal,
        ! no entando nos ultimos dts bins ao menos um eletrodo ter se
        ! excitado. Sendo assim, precisamos marcar mais essa avalache.
        if ( atLeastOneBinAlive ) then
           write(27,*) j - jrel
!           write(*,*) 'Ultimo caso: ', j - jrel
        end if

        ! Agora sim basta só retornar
        return
     end if

     ! Nao mais precisa contar como primeiro bin
     j0 = 1

  end do

  close(27)

  return
end subroutine death_time_BeggsPlenz

!
! Calcula estimador para as probabilidades de
! criação de novos nós ativos
!
subroutine pr_estimate(N, Madj, netstate, mat_adj, m, Nsteps_max, VP, x)

  integer, intent(in)    :: N, Nsteps_max, m, Madj
  real(8), intent(in)    :: mat_adj(N, 0:Madj)

  integer, intent(inout) :: netstate(N)
  real(8), intent(inout) :: VP(0:N), x

  integer                :: contador, contador_old, aux, NN, j, jj, p, netstate_new(N) , dt
  real(8)                :: norma
  integer                :: num_exc(N), estado, nbindex
  logical                :: condicao

  real(8)                :: getActivity, ran1, delta

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Zerando o vetor de probabilidades e zerando a contagem
! de excitacoes novas
  do j = 1, N
     VP(j) = 0.d0
  enddo

! Como o run jah inicia-se com um cara excitado...
  Vp(1) = 1
  contador = 1
  x = 0

! Indice principal que vamos percorrer
  j = 0

  dt = Nsteps_max

  do while (j .lt. Nsteps_max)

     ! Incremento do indice
     j = j + 1

     ! Zerando a contagem de excitacoes
     do j = 1, N
        num_exc(j) = -1
     enddo

     ! contadores em igualdade
     contador_old = contador

     ! Percorrendo a rede
     do p = 1, N

        estado = netstate(p)

        ! Neuronio excitado
        if ( estado .eq. 1 ) then

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           ! Marcando esse noh como participante da avalanche
           num_exc( p ) = 0

           do jj = 1, aux

              ! indice do vizinho
              nbindex = int( mat_adj(p,jj) )

              ! Excita ou nao excita?
              condicao = ( netstate( nbindex ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 )  )

              if ( condicao ) then

                 netstate_new( nbindex ) = 1
                 num_exc( p ) = num_exc( p ) + 1

              end if

           end do

        else if ( estado .gt. 1 ) then

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Atualizando a probabilidade
     do jj = 1, N
        if ( num_exc(jj) .ge. 0 ) then
           VP( num_exc(jj) ) = VP( num_exc(jj) ) + 1
        end if

        ! Contando numero de caras jah excitados ateh o momento
        contador = contador + delta(1, netstate_new(jj))

     enddo

     x = dfloat( contador_old - 1 )/dfloat(contador)

     ! Atualizando o estado da rede
     netstate = netstate_new

     ! Testa se a rede jah morreu
     if ( getActivity(N, netstate_new) .eq. 0.d0 ) then
        dt = j
        j = Nsteps_max + 10
     end if

  end do

  ! Finalizando o estimador para a probabilidade
  norma = 1.d0/dfloat(contador)

  do j = 1, N
     VP( num_exc(j) ) = VP( num_exc(j) )*norma
  enddo

  x = x/dt

  return
end subroutine pr_estimate

!
! Routine optimized to get avalanches sizes without repetition
!
!
integer function get_avalanche(N, Madj, netstate, mat_adj, m, h, Nsteps, lifetime, rho) result(soma)

  integer, intent(in)    :: N, Nsteps, m, Madj
  real(8), intent(in)    :: h, mat_adj(N, 0:Madj)
  integer                :: aux, NN, j, jj, p, netstate_new(N), norep(N)
  real(8)                :: prob, auxp, active_neurons
  real(8), intent(inout) :: rho(N)
  integer, intent(inout) :: netstate(N), lifetime

! Coisas auxiliares
  integer                :: contador, progressbar, idx
  integer                :: k

! Funcoes externas
  real(8)                :: getActivity, ran1
  integer                :: getActiveNeuronsNoRepeat

! Replacing garbage with zeros.
  do j = 1, N
     netstate(j) = 0
     norep(j) = 0
  end do

! Exciting one randomly chosen hub neuron
  aux = int( N*ran1() + 1)
  netstate(aux) = 1

! Initial condition
  rho(1) = getActivity(N, netstate)

! Contagem inicial dos neuronios
  soma = getActiveNeuronsNoRepeat(N, netstate, norep)

! Prova dos 9: soma tem que ser, necessariamente, 1 neste
! momento do programa!
!    write(*,*) soma

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

  do j = 1, Nsteps

     do p = 1, N

        if ( netstate(p) .eq. 1 ) then

           ! Atualizando o proprio neuronio
           netstate_new(p) = modulo(netstate(p) + 1, m)
           !netstate_new(p) = 2 -> este caso nao compreende quando nao ha estados refratarios

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           do jj = 1, aux

              ! Indice para nao ficar acessando desnecessariamente mat_adj
              idx = int( mat_adj(p,jj) )

              if ( idx .eq. 0 ) then
                 write(*,*) mat_adj(p,0), mat_adj(p,jj), jj
                 read(*,*)
              end if

              if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then

                 netstate_new(idx) = 1

              end if
           end do

        else if ( netstate(p) .gt. 1 ) then

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Atualizando o estado da rede
     netstate = netstate_new

     ! Calculando quantos neuronios "novos" participaram na
     ! ultima iteracao!
     soma = soma + getActiveNeuronsNoRepeat(N, netstate, norep)

     ! Verificando se nao ha nenhum neuronio ativo, contando
     ! as repeticoes.
     active_neurons = getActivity(N, netstate)

     rho(j + 1) = active_neurons

     if ( active_neurons .eq. 0 ) then
        lifetime = j
        return
     end if

  end do

  lifetime = Nsteps
  return
end function get_avalanche

!
! Routine optimized to get avalanches sizes with repetition
!
!
integer function get_avalanche_wrep(N, Madj, netstate, mat_adj, m, h, Nsteps) result(soma)

  integer, intent(in)    :: N, Nsteps, m, Madj
  real(8), intent(in)    :: h, mat_adj(N, 0:Madj)
  integer                :: aux, NN, j, jj, p, netstate_new(N)
  real(8)                :: prob, auxp, active_neurons
  integer, intent(inout) :: netstate(N)

! Coisas auxiliares
  integer                :: contador, progressbar, idx
  integer                :: k

! Funcoes externas
  real(8)                :: getActivity, ran1
  integer                :: getActiveNeurons

! Replacing garbage with zeros.
  do j = 1, N
     netstate(j) = 0
  end do

! Exciting one randomly chosen hub neuron
  aux = int( N*ran1() + 1)
  netstate(aux) = 1

! Contagem inicial dos neuronios
  soma = getActiveNeurons(N, netstate)

! Prova dos 9: soma tem que ser, necessariamente, 1 neste
! momento do programa!
!    write(*,*) soma

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

  do j = 1, Nsteps

     do p = 1, N

        if ( netstate(p) .eq. 1 ) then

           ! Atualizando o proprio neuronio
           netstate_new(p) = 2

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           do jj = 1, aux

              ! Indice para nao ficar acessando desnecessariamente mat_adj
              idx = int( mat_adj(p,jj) )

              if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then

                 netstate_new(idx) = 1

              end if
           end do

        else if ( netstate(p) .gt. 1 ) then

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Atualizando o estado da rede
     netstate = netstate_new

     ! Calculando quantos neuronios "novos" participaram na
     ! ultima iteracao!
     soma = soma + getActiveNeurons(N, netstate)

     ! Verificando se nao ha nenhum neuronio ativo, contando
     ! as repeticoes.
     active_neurons = getActivity(N, netstate)
     if ( active_neurons .eq. 0 ) then
        return
     end if

  end do

  return
end function get_avalanche_wrep

!
! death_time
!
! Retorna o tempo em que a rede parou de funcionar sem um
! estimulo externo
!
subroutine sizeavalanche_loose(N, Madj, netstate, mat_adj, m, Nsteps_max, outputfile, pl)

  character(len=100)     :: outputfile
  integer, intent(in)    :: N, Nsteps_max, m, Madj
  real(8), intent(in)    :: mat_adj(N, 0:Madj), pl
  integer                :: contador, aux, NN, j, jj, p, progressbar, netstate_new(N), idx, soma
  integer                :: norep(N)
  integer, intent(inout) :: netstate(N)
  logical                :: condicao, Teste_Are_ElecDead, new_av_started

  ! funcoes
  real(8)                :: ran1, getActivity
  logical                :: isDead, isDead_loose

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Defining the norep vector
  do j = 1, N
     norep(j) = 0
  end do

! Arquivo para escrever os resulstados
  open(unit=27, file=outputfile, access="append")

! Iniciando as variaveis que contam o numero de geracoes
! passadas depois do primeiro seed
  j = 0

! Starting the avalanche size properly
  soma = 1

! O seed eh colocado em um dos neuronios avistados por um eletrodo,
! caso contrario nao teria se iniciado avalanche nenhuma.
  new_av_started = .true.

  do while (j .lt. Nsteps_max)

     j = j + 1

     do p = 1, N

        if ( netstate(p) .eq. 1 ) then

           ! Atualizando o proprio neuronio
           netstate_new(p) = 2

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           if ( aux .gt. 0 ) then

              do jj = 1, aux

                 ! Indice para nao ficar acessando desnecessariamente mat_adj
                 idx = int( mat_adj(p,jj) )

                 if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0 ) ) ) then

                    netstate_new(idx) = 1

                 end if
              end do
           end if

        else if ( netstate(p) .gt. 1 ) then

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Teste nos eletrodos

     ! Pode acontecer de uma avalanche terminar (para os eletrodos) e haver um
     ! espaço de tempo em que nenhum eletrodo sente potencial. Por isso, eh
     ! necessario testar se uma nova avalanche, para os eletrodos, jah se iniciou
     ! antes de marcar mais tempos. Isso eh feito via chaveamento da variavel
     ! logica new_av_started.

     ! Calculando quantos neuronios "novos" participaram na
     ! ultima iteracao!
     call getActiveNeuronsNoRepeat_loose(N, netstate_new, norep, pl, soma, Teste_Are_ElecDead)

     ! Testa se hah algum eletrodo ativo
     if ( Teste_Are_ElecDead .and. new_av_started ) then

        write(27,*) soma
        soma = 0

        ! RE-defining the norep vector
        do j = 1, N
           norep(j) = 0
        end do

        new_av_started = .false.

     end if

     ! Se nao houver nenhum ativo, testa se uma nova avalanche (para eletrodos)
     ! se iniciou.
     if ( .not. new_av_started ) then
        new_av_started = .not. Teste_Are_ElecDead
     end if

     ! Testa se a rede jah morreu
     ! Testamos se a rede morre apenas no final porque pode ser que a rede morra sem
     ! que os eletrodos sejam excitados em suas ultimas excitacoes.
     if ( isDead(N, netstate_new) ) then

        return

     end if

     ! Em caso de continuacao do algoritmo, atualizando o estado da rede
     netstate = netstate_new

  end do

  close(27)

  return
end subroutine sizeavalanche_loose

!
! Update
!
! Salva a atividade em um arquivo externo
!
subroutine returnmap(N, Madj, netstate, mat_adj, m, h, Nsteps, RM, jindx)

  integer, intent(in)    :: N, Nsteps, m, Madj, jindx
  real(8), intent(in)    :: h, mat_adj(N, 0:Madj)
  integer                :: contador, aux, NN, j, jj, p, progressbar, netstate_new(N), last_spktm
!  real(8)                :: prob, auxp
  integer, intent(inout) :: netstate(N), RM(0:Nsteps)
  real(8)                :: getActivity, ran1

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

  last_spktm = 0
  if ( netstate(jindx) .ne. 1 ) then
     netstate(jindx) = 1
  end if

  nisis = 0

! Primeira marcacao de atividade
  write(1,*) 0, getActivity(N, netstate)

! Setando o progressbar
  contador = 0
  progressbar = Nsteps/30

  write(*,"(A)",advance='no') " >> ["

  do j = 1, Nsteps

     do p = 1, N

        ! Neuronio pode ser excitado
        if ( ( netstate(p) .eq. 0 ) .and. ( netstate_new(p) .eq. 0 ) ) then

           ! O estimulo externo pode excitar o neuronio
           if ( ran1() .lt. h ) then
              netstate_new(p) = 1
           end if

        else if ( netstate(p) .eq.  1 ) then

           netstate_new(p) = 2

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           do jj = 1, aux

              idx = int( mat_adj(p,jj) )

              if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0) ) ) then
                 netstate_new( idx ) = 1
              end if

!              write(*,*) jj, aux,  mod( mat_adj(p,jj), 1d0)
!              read(*,*)

           end do

        else

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Atualizando o estado da rede
     netstate = netstate_new

     CALL progressbar_update(contador, progressbar)

     if ( netstate(jindx) .eq. 1 ) then

        RM(nisis) = j - last_spktm
        nisis = nisis + 1

        last_spktm = j

     end if

  end do

! Finalizando o contador
  write(*,"(A)") "]"

end subroutine returnmap

!
! phasecode
!
! Funcao que retorna a atividade media apos um periodo dado
! de iteracoes
!
real(8) function phasecode(N, Madj, netstate, mat_adj, phi, m, h, Nsteps) result(media)

  integer, intent(in)    :: N, Nsteps, m, Madj
  real(8), intent(in)    :: h, mat_adj(N, 0:Madj)  ! Matriz de adjacencias
  integer, intent(inout) :: netstate(N)            ! Vetor de estados
  integer, intent(inout) :: phi(N)                 ! Vetor de fases
  integer                :: netstate_new(N)

! Indices
  integer                :: j, jj, NN, p, aux, idx
  integer                :: contador, progressbar, chave

! Funcoes externas
  real(8)                :: getActivity, ran1, syncOverlap
  logical                :: isDead

! Como o algoritmo eh sincrono, entao eh necessario
! guardar os estados atualizados em um novo vetor.
  netstate_new = netstate

! Inicializando a media
  media = 0d0

  do j = 1, Nsteps

     do p = 1, N

        ! Neuronio pode ser excitado
        if ( ( netstate(p) .eq. 0 ) .and. ( netstate_new(p) .eq. 0 ) .and. p .lt. 11 ) then

           ! O estimulo externo pode excitar o neuronio
           if ( ran1() .lt. h ) then
              netstate_new(p) = 1
           end if

        else if ( netstate(p) .eq.  1 ) then

           ! This was wrong: it don't catch the case where m = 2
           ! netstate_new(p) = 2
           netstate_new(p) = modulo(netstate(p) + 1, m)

           ! Para nao ficar acessando desnecessariamente mat_adj(p, 0)
           aux = int( mat_adj(p, 0) )

           do jj = 1, aux

              idx = int( mat_adj(p,jj) )

              if ( ( netstate( idx ) + netstate_new( idx ) .eq. 0 ) .and. ( ran1() .lt. mod( mat_adj(p,jj), 1d0) ) ) then
                 netstate_new( idx ) = 1
              end if

!              write(*,*) jj, aux,  mod( mat_adj(p,jj), 1d0)
!              read(*,*)

           end do

        else

           netstate_new(p) = modulo(netstate(p) + 1, m)

        end if

     end do

     ! Se a rede estiver morta e não houver estimulo externo, não adianta prosseguir.
     if ( isDead(N, netstate_new) .and. ( h .eq. 0.d0 ) ) then

        media = media/float(Nsteps)

        return
     end if

     ! Atualizando o estado da rede
     netstate = netstate_new

     ! Imprimindo em arquivo a historia
     media = media + syncOverlap(N, netstate, phi)
     !write(73,*) syncOverlap(N, netstate, phi)

     if ( .true. ) then
        open(unit=27, file="activity.data", access="append")
        write(27,*) 'Iteracao: ', j
        do jj = 1, N
           if ( netstate(jj) .eq. 1 ) then
              write(27,*) jj
           endif
        enddo
        write(27,*) 'fim'
        write(27,*)

        close(27)
     end if

  end do

  media = media/dfloat(Nsteps)

  return
end function phasecode


      SUBROUTINE INITPT(N,X,NPROB,FACTOR)                               00000010
      INTEGER N,NPROB
      DOUBLE PRECISION FACTOR
      DOUBLE PRECISION X(N)
C     **********
C
C     SUBROUTINE INITPT
C
C     THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE
C     FUNCTIONS DEFINED BY SUBROUTINE OBJFCN. THE SUBROUTINE RETURNS
C     IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR
C     THE SEVENTH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN
C     THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS
C     THE VECTOR  X(J) = FACTOR, J=1,...,N.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE INITPT(N,X,NPROB,FACTOR)
C
C     WHERE
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE.
C
C       X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
C         STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
C
C       NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
C         NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
C
C       FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
C         THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
C         MULTIPLICATION IS PERFORMED.
C
C     MINPACK. VERSION OF JULY 1978.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER IVAR,J
      DOUBLE PRECISION C1,C2,C3,C4,FIVE,H,HALF,ONE,TEN,THREE,TWENTY,
     1                 TWNTF,TWO,ZERO
      DOUBLE PRECISION DFLOAT
      DATA ZERO,HALF,ONE,TWO,THREE,FIVE,TEN,TWENTY,TWNTF
     1     /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,5.0D0,1.0D1,2.0D1,2.5D1/
      DATA C1,C2,C3,C4 /4.0D-1,2.5D0,1.5D-1,1.2D0/
      DFLOAT(IVAR) = IVAR
C
C     SELECTION OF INITIAL POINT.
C
      GO TO (10,20,30,40,50,60,80,100,120,140,150,160,170,190,210,230,
     1       240,250), NPROB
C
C     HELICAL VALLEY FUNCTION.
C
   10 CONTINUE
      X(1) = -ONE
      X(2) = ZERO
      X(3) = ZERO
      GO TO 270
C
C     BIGGS EXP6 FUNCTION.
C
   20 CONTINUE
      X(1) = ONE
      X(2) = TWO
      X(3) = ONE
      X(4) = ONE
      X(5) = ONE
      X(6) = ONE
      GO TO 270
C
C     GAUSSIAN FUNCTION.
C
   30 CONTINUE
      X(1) = C1
      X(2) = ONE
      X(3) = ZERO
      GO TO 270
C
C     POWELL BADLY SCALED FUNCTION.
C
   40 CONTINUE
      X(1) = ZERO
      X(2) = ONE
      GO TO 270
C
C     BOX 3-DIMENSIONAL FUNCTION.
C
   50 CONTINUE
      X(1) = ZERO
      X(2) = TEN
      X(3) = TWENTY
      GO TO 270
C
C     VARIABLY DIMENSIONED FUNCTION.
C
   60 CONTINUE
      H = ONE/DFLOAT(N)
      DO 70 J = 1, N
         X(J) = ONE - DFLOAT(J)*H
   70    CONTINUE
      GO TO 270
C
C     WATSON FUNCTION.
C
   80 CONTINUE
      DO 90 J = 1, N
         X(J) = ZERO
   90    CONTINUE
      GO TO 270
C
C     PENALTY FUNCTION I.
C
  100 CONTINUE
      DO 110 J = 1, N
         X(J) = DFLOAT(J)
  110    CONTINUE
      GO TO 270
C
C     PENALTY FUNCTION II.
C
  120 CONTINUE
      DO 130 J = 1, N
         X(J) = HALF
  130    CONTINUE
      GO TO 270
C
C     BROWN BADLY SCALED FUNCTION.
C
  140 CONTINUE
      X(1) = ONE
      X(2) = ONE
      GO TO 270
C
C     BROWN AND DENNIS FUNCTION.
C
  150 CONTINUE
      X(1) = TWNTF
      X(2) = FIVE
      X(3) = -FIVE
      X(4) = -ONE
      GO TO 270
C
C     GULF RESEARCH AND DEVELOPMENT FUNCTION.
C
  160 CONTINUE
      X(1) = FIVE
      X(2) = C2
      X(3) = C3
      GO TO 270
C
C     TRIGONOMETRIC FUNCTION.
C
  170 CONTINUE
      H = ONE/DFLOAT(N)
      DO 180 J = 1, N
         X(J) = H
  180    CONTINUE
      GO TO 270
C
C     EXTENDED ROSENBROCK FUNCTION.
C
  190 CONTINUE
      DO 200 J = 1, N, 2
         X(J) = -C4
         X(J+1) = ONE
  200    CONTINUE
      GO TO 270
C
C     EXTENDED POWELL SINGULAR FUNCTION.
C
  210 CONTINUE
      DO 220 J = 1, N, 4
         X(J) = THREE
         X(J+1) = -ONE
         X(J+2) = ZERO
         X(J+3) = ONE
  220    CONTINUE
      GO TO 270
C
C     BEALE FUNCTION.
C
  230 CONTINUE
      X(1) = ONE
      X(2) = ONE
      GO TO 270
C
C     WOOD FUNCTION.
C
  240 CONTINUE
      X(1) = -THREE
      X(2) = -ONE
      X(3) = -THREE
      X(4) = -ONE
      GO TO 270
C
C     CHEBYQUAD FUNCTION.
C
  250 CONTINUE
      H = ONE/DFLOAT(N+1)
      DO 260 J = 1, N
         X(J) = DFLOAT(J)*H
  260    CONTINUE
  270 CONTINUE
C
C     COMPUTE MULTIPLE OF INITIAL POINT.
C
      IF (FACTOR .EQ. ONE) GO TO 320
      IF (NPROB .EQ. 7) GO TO 290
         DO 280 J = 1, N
            X(J) = FACTOR*X(J)
  280       CONTINUE
         GO TO 310
  290 CONTINUE
         DO 300 J = 1, N
            X(J) = FACTOR
  300       CONTINUE
  310 CONTINUE
  320 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE INITPT.
C
      END


      subroutine grass_wway

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine controls the grass waterways
!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ihru            |none          |HRU number
!!    surfq(:)	   	|mm H2O        |amount of water in surface runoff generated
!!	grwat_n(:)      |none          |Mannings's n for grassed waterway
!!	grwat_i(:)      |none          |On/off Flag for waterway simulation
!!	grwat_l(:)      |km	           |Length of Grass Waterway
!!	grwat_w(:)      |none          |Width of grass waterway
!!	grwat_d(:)      |m             |Depth of Grassed waterway
!!	grwat_s(:)      |m/m           |Slope of grass waterway
!!	grwat_spcon(:)  |none          |sediment transport coefficant defined by user
!!	tc_gwat(:)      |none          |Time of concentration for Grassed waterway and its drainage area
!!	mhru
!!    sedyld(:)       |metric tons   |daily soil loss caused by water erosion

!!    wat_phi(1,:)        |m^2           |cross-sectional area of flow at bankfull
!!                                   |depth
!!    wat_phi(2,:)        |none          |
!!    wat_phi(3,:)        |none          |
!!    wat_phi(4,:)        |none          |
!!    wat_phi(5,:)        |m^3/s         |flow rate when reach is at bankfull depth
!!    wat_phi(6,:)        |m             |bottom width of main channel
!!    wat_phi(7,:)        |m             |depth of water when reach is at bankfull
!!                                   |depth
!!    wat_phi(8,:)        |m/s           |average velocity when reach is at
!!                                   |bankfull depth
!!    wat_phi(9,:)        |m/s           |wave celerity when reach is at
!!                                   |bankfull depth
!!    wat_phi(10,:)       |hr            |storage time constant for reach at
!!                                   |bankfull depth (ratio of storage to
!!                                   |discharge)
!!    wat_phi(11,:)       |m/s           |average velocity when reach is at
!!                                   |0.1 bankfull depth (low flow)
!!    wat_phi(12,:)       |m/s           |wave celerity when reach is at
!!                                   |0.1 bankfull depth (low flow)
!!    wat_phi(13,:)       |hr            |storage time constant for reach at
!!                                   |0.1 bankfull depth (low flow) (ratio
!!                                   |of storage to discharge)
!!    sedyld(:)       |metric tons   |daily soil loss caused by water erosion
!!    surfq(:)        |mm H2O        |surface runoff generated on day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    sedyld(:)       |metric tons   |daily soil loss caused by water erosion
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    peakr       |m^3/s         |peak runoff rate for the day
!!	chflow_m3   |m^3/s         |Runoff in CMS
!!	chflow_day	|m^3/day	   |Runoff
!!	K           |m^3/s         |Total number of HRUs plus this HRU number
!!	rcharea     |m^2           |cross-sectional area of flow
!!    rchdep      |m             |depth of flow on day
!!    sf_area     |m^2           |area of waterway sides in sheetflow
!!    sf_sed      |kg/m^2        |sediment loads on sides of waterway
!!    surq_remove |%             |percent of surface runoff capture in VFS
!!    sed_remove  |%             |percent of sediment capture in VFS
!!    vc          |m/s           |flow velocity in reach
!!	Sedin		|mg			   | Sediment in waterway
!!	Sedint   	|mg			   | Sediment into waterway channel
!!	Sedout		|mg			   | Sediment out of waterway channel
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~
      use parm
      real*8 :: chflow_m3, sf_area, surq_remove, sf_sed ,sed_remove,vc,
     & chflow_day, rh
!!	set variables
      j = ihru

!!	do this only if there is surface runoff this day
      if (surfq(j) > 0.001) then

!!        compute channel peak rate using SCS triangular unit hydrograph
!!		Calculate average flow based on 3 hours of runoff
		chflow_day = 1000. * surfq(j) * hru_km(ihru)
          chflow_m3 = chflow_day/10800
          peakr = 2. * chflow_m3 / (1.5 * tc_gwat(j))

!! if peak rate is greater than bankfull discharge
          if (peakr > wat_phi(5,j)) then
            rcharea = wat_phi(1,j)
            rchdep = grwat_d(j)
          else
!!          find the crossectional area and depth for todays flow
!!          by iteration method at 1cm interval depth
!!          find the depth until the discharge rate is equal to volrt
            sdti = 0.
            rchdep = 0.

            Do While (sdti < peakr)
              rchdep = rchdep + 0.01
              rcharea = (wat_phi(6,j) + 8 * rchdep) * rchdep
              p = wat_phi(6,j) + 2. * rchdep * Sqrt(1. + 8 *
     *           8)
              rh = rcharea / p
              sdti = Qman(rcharea, rh, grwat_n(j), grwat_s(j))
            end do
          end if

!!        Sediment yield (kg) from fraction of area drained by waterway

		  sedin = sedyld(ihru)
!! Calculate sediment losses in sheetflow at waterway sides

!! calculate area of sheeflow in m^2 assumne *:1 side slope 8.06 = (8^2+1^2)^.5
	sf_area = (grwat_d(j) - rchdep) * 8.06 * grwat_l(j) * 1000
!! Adjust Area to account for flow nonuniformities White and Arnold 2009 found half of flow in VFS
!!handled by 10% of VFS area. Waterways likely even more concentrated Assume only 20% of sideslope acts as filters
      if (sf_area > 1.e-6) then
	  sf_area = sf_area * 0.20
!! calculate runoff depth over sheetflow area in mm
	  sf_depth=surfq(j)  * hru_km(ihru) * 1000000/sf_area
!! Calculate sediment load on sheetflow area kg/ha
	  sf_sed = sedin * 1000 / sf_area
!! Calculate runoff and sediment losses taken from mostly from filter.f
      end if

	if (sf_area > 0.) then
!!		surq_remove = 75.8 - 10.8 * Log(sf_depth) + 25.9
!!     &    * Log(sol_k(1,j))
	!! Simpler form derived from vfsmod simulations. r2 = 0.57 Publication pending white and arnold 2008

	    surq_remove = 95.6 - 10.79 * Log(sf_depth)
		if (surq_remove > 100.) surq_remove = 100.
		if (surq_remove < 0.) surq_remove = 0.

		sed_remove = 79.0 - 1.04 * sf_sed + 0.213 * surq_remove
		if (sed_remove > 100.) sed_remove = 100.
		if (sed_remove < 0.) sed_remove = 0.

	Else
		sed_remove = 0
		surq_remove = 0
	endif
	sedint = sedin * (1. - sed_remove / 100.)

!!        calculate flow velocity
          vc = 0.001
          if (rcharea > 1.e-4) then
            vc = peakr / rcharea
            if (vc > wat_phi(9,j)) vc = wat_phi(9,j)
          end if

!!        compute deposition in the waterway
          cyin = 0.
          cych = 0.
          depnet = 0.
          deg = 0.
          dep = 0.
!! if there is significant flow calculate
          if (chflow_m3 > 1.e-4) then
!! Calculate sediment concentration in inflow mg/m^3
            cyin = sedint / chflow_day
!! Calculate sediment transport capacity mg/m^3
            cych = grwat_spcon(j) * vc ** 1.5
!! Calculate deposition in mg
            depnet = chflow_day * (cyin - cych)
            if (depnet < 0.) depnet = 0
		  if (depnet > sedint) depnet = sedint
          endif
!! Calculate sediment out of waterway channel
	sedout = sedint - depnet

!! Calculate total fraction of sediment and surface runoff transported
      if (sedyld(j) < .0001) sedyld(j) = .0001
	sed_frac =  sedout/sedyld(j)

	surq_frac = 1 - surq_remove/100

!! Subtract reductions from sediment, nutrients, bacteria, and pesticides NOT SURFACE RUNOFF to protect water balance
      sedtrap = sedyld(j) * (1. - sed_frac)
	sedyld(j) = sedyld(j) * sed_frac
	sedminpa(j) = sedminpa(j) * sed_frac
	sedminps(j) = sedminps(j) * sed_frac
	sedorgp(j) = sedorgp(j) * sed_frac
	surqsolp(j) = surqsolp(j) * surq_frac
	sedorgn(j) = sedorgn(j) * sed_frac
	surqno3(j) = surqno3(j) * surq_frac

        xrem = 0.
	  if (sedtrap <= lagyld(j)) then
	    lagyld(j) = lagyld(j) - sedtrap
	  else
	    xrem = sedtrap - lagyld(j)
	    lagyld(j) = 0.
	    if (xrem <= sanyld(j)) then
	      sanyld(j) = sanyld(j) - xrem
	    else
	      xrem = xrem - sanyld(j)
	      sanyld(j) = 0.
	      if (xrem <= sagyld(j)) then
	        sagyld(j) = sagyld(j) - xrem
	      else
	        xrem = xrem - sagyld(j)
	        sagyld(j) = 0.
	        if (xrem <= silyld(j)) then
	          silyld(j) = silyld(j) - xrem
	        else
	          xrem = xrem - silyld(j)
	          silyld(j) = 0.
	          if (xrem <= clayld(j)) then
	            clayld(j) = clayld(j) - xrem
	          else
	            xrem = xrem - clayld(j)
	            clayld(j) = 0.
	          end if
	        end if
	      end if
	    end if
	  end if
        sanyld(j) = Max(0., sanyld(j))
        silyld(j) = Max(0., silyld(j))
        clayld(j) = Max(0., clayld(j))
        sagyld(j) = Max(0., sagyld(j))
        lagyld(j) = Max(0., lagyld(j))

!! Calculate pesticide removal
!! based on the sediment and runoff removal only
      if (hrupest(j) == 1) then
        do k = 1, npmx
          pst_surq(k,j) = pst_surq(k,j) * surq_frac
          pst_sed(k,j) = pst_sed(k,j) * (1. - sed_remove / 100.)
        end do
      end if
!! compute bacteria reductions
      bactrop = bactrop * surq_frac
      bactrolp = bactrolp * surq_frac
      bactsedp = bactsedp * sed_frac
      bactsedlp = bactsedlp * sed_frac

      Endif
      return
      end


      SUBROUTINE PHO_GHHIAS(Nevent,Eep,Een,Na,Nz)
C**********************************************************************
C
C     interface to call PHOJET (variable energy run) for
C     gamma-hadron collisions in heavy ion - hadron
C     collisions (form factor approach)
C
C     input:     EEP     LAB system energy of proton (GeV)
C                EEN     LAB system energy per nucleon (GeV)
C                NA      atomic number of ion/hadron
C                NZ      charge number of ion/hadron
C                NEVENT  number of events to generate
C            from /LEPCUT/:
C                YMIN2   lower limit of Y
C                        (energy fraction taken by photon from hadron)
C                YMAX2   upper cutoff for Y, necessary to avoid
C                        underflows
C                Q2MIN2  minimum Q**2 of photons (should be set to 0)
C                Q2MAX2  maximum Q**2 of photons (if necessary,
C                        corrected according size of hadron)
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION alpha , amp , amp2 , ay1 , ay2 , ays1 , ays2 ,
     &                 cof , day2 , delly , DT_RNDM , e1y , ee , Een ,
     &                 Eep , egam , ff , ff2 , flux , fm2gev
      DOUBLE PRECISION gamma , ghdiff , hima2 , himass , hiradi , p1 ,
     &                 p2 , PI , q22av2 , q22ave , q22max , q22min ,
     &                 q2e , q2log2 , q2low2 , q2maxh , q2p1 , q2p2 ,
     &                 sif , sigcur
      DOUBLE PRECISION sigmax , weight , wgh , wgmax , wgmax2 , wgy ,
     &                 wgy2 , x2del , x2max , x2min , xdel , xf , xmax ,
     &                 xmin , y1 , y2 , yeff , ymax , ymi , ymin
      DOUBLE PRECISION yq2 , yy2max , yy2min
      INTEGER i , irej , iside , itrw , itry , k , max_tab , Na ,
     &        Nevent , niter , niters , Nz, Nprint
      SAVE

      PARAMETER (PI=3.141592653589793238462643383279D+00)

C  input/output channels
      INCLUDE 'inc/poinou'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  event debugging information
      INCLUDE 'inc/podebg'
C  photon flux kinematics and cuts
      INCLUDE 'inc/pofcut'
C  gamma-lepton or gamma-hadron vertex information
      INCLUDE 'inc/pofsrc'
C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INCLUDE 'inc/pohdfl'

C  standard particle data interface

      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

C  event weights and generated cross section
      INCLUDE 'inc/powght'

      DIMENSION p1(4) , p2(4)

      IF ( LPRi.GT.4 ) WRITE (LO,'(2(/1X,A))')
     &                       'PHO_GHHIAS: hadron-gamma event generation'
     &                       ,
     &                       '-----------------------------------------'
C  hadron size and mass
      fm2gev = 5.07D0
      himass = DBLE(Na)*0.938D0
      hima2 = himass**2
      hiradi = 1.2D0*fm2gev*DBLE(Na)**0.333
      alpha = DBLE(Nz**2)/137.D0
      amp = 0.938D0
      amp2 = amp**2
C  correct Q2MAX2 according to hadron size
      q2maxh = 2.D0/hiradi**2
      Q2Max2 = MIN(Q2Max2,q2maxh)
      IF ( Q2Max2.LT.1.D-20 ) Q2Max2 = q2maxh
C  total hadron / heavy ion energy
      ee = Een*DBLE(Na)
      gamma = ee/himass
C  setup /POFSRC/
      GAMsrc(2) = gamma
      RADsrc(2) = hiradi
      AMSrc(2) = himass
C  check kinematic limitations
      ymi = ECMin**2/(4.D0*ee*Eep)
      IF ( YMIn2.LT.ymi ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,2E12.5)')
     &         'PHO_GHHIAS: ymin2 increased to (old/new)' , YMIn2 , ymi
         YMIn2 = ymi
      ELSE IF ( YMIn2.GT.ymi ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &         'PHO_GHHIAS:' , 'ECM-CUT CORRESPONDS TO YMIN2 OF' , ymi ,
     &        '  INSTEAD OF' , YMIn2
      END IF
C  kinematic limitation
      q2low2 = MAX(Q2Min2,hima2*YMIn2**2/(1.D0-YMIn2))
C  debug output
      IF ( LPRi.GT.4 ) WRITE (LO,'(/6X,A,2I4)')
     &                         'MASS NUMBER, CHARGE NUMBER  ' , Na , Nz
      IF ( LPRi.GT.4 ) WRITE (LO,'(6X,A,E12.5)')
     &                         'HEAVY ION MASS (GeV)        ' , himass
      IF ( LPRi.GT.4 ) WRITE (LO,'(6X,A,E12.5)')
     &                         'HEAVY ION  RADIUS (GeV**-1) ' , hiradi
      IF ( LPRi.GT.4 ) WRITE (LO,'(6X,A,2E12.5)')
     &                         'Q**2 RANGE PHOTON 2 (GEV**2)' , q2low2 ,
     &                        Q2Max2
      IF ( LPRi.GT.4 ) WRITE (LO,'(6X,A,2E12.5)')
     &                         'Y RANGE PHOTON 2            ' , YMIn2 ,
     &                        YMAx2
      IF ( LPRi.GT.4 ) WRITE (LO,'(6X,A,2E12.5)')
     &                         'SQRT(S) PER NUCLEON, TOTAL  ' ,
     &                        2.D0*SQRT(Een*Eep) , 2.D0*SQRT(ee*Eep)
      IF ( LPRi.GT.4 ) WRITE (LO,'(6X,A,2E12.5)')
     &                         'INV.MASS HADRON-PHOTON      ' , ECMin ,
     &                        ECMax
      IF ( LPRi.GT.4 ) WRITE (LO,'(6X,A,I10)')
     &                         'EVENTS TO PROCESS           ' , Nevent
      IF ( q2low2.GE.Q2Max2 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,2E12.4)')
     &         'PHO_GHHIAS:ERROR:inconsistent Q**2 range 2' , q2low2 ,
     &        Q2Max2
         CALL PHO_ABORT
      END IF
C  hadron numbers set to 0
      IDPsrc(1) = 0
      IDPsrc(2) = 0
      IDBsrc(1) = 0
      IDBsrc(2) = 0
C
      max_tab = 100
      ymax = YMAx2
      ymin = YMIn2
      xmax = LOG(ymax)
      xmin = LOG(ymin)
      xdel = xmax - xmin
      delly = LOG(ymax/ymin)/DBLE(max_tab-1)
      DO i = 1 , max_tab
         y1 = EXP(xmin+delly*DBLE(i-1))
         q2low2 = MAX(Q2Min2,hima2*y1*y1/(1.D0-y1))
         IF ( q2low2.GE.Q2Max2 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,2E12.4)')
     &            'PHO_GHHIAS: ymax2 changed from/to' , YMAx2 , y1
            YMAx2 = MIN(y1,YMAx2)
            GOTO 100
         END IF
      END DO
C
 100  x2max = LOG(YMAx2)
      x2min = LOG(YMIn2)
      x2del = x2max - x2min
      delly = LOG(YMAx2/YMIn2)/DBLE(max_tab-1)
      flux = 0.D0
      IF ( LPRi.GT.4 .AND. IDEb(30).GE.1 ) WRITE (LO,'(/1X,A,I5)')
     &      'PHO_GHHIAS: table of raw photon flux (side 2)' , max_tab
      DO i = 1 , max_tab
         y2 = EXP(x2min+delly*DBLE(i-1))
         q2low2 = MAX(Q2Min2,hima2*y2*y2/(1.D0-y2))
         ff = ((1.D0+(1.D0-y2)**2)/y2*LOG(Q2Max2/q2low2)
     &        -2.D0*hima2*y2*(1.D0/q2low2-1.D0/Q2Max2))*alpha/(2.D0*PI)
         flux = flux + y2*ff
         IF ( LPRi.GT.4 .AND. IDEb(30).GE.1 ) WRITE (LO,'(5X,2E15.4)')
     &        y2 , ff
      END DO
      flux = flux*delly
      IF ( LPRi.GT.4 .AND. IDEb(30).GE.1 ) WRITE (LO,'(1X,A,E12.4)')
     &      'PHO_GHHIAS: integrated flux:' , flux
C
C  hadron
      p1(1) = 0.D0
      p1(2) = 0.D0
      p1(3) = -SQRT(Eep**2-amp2)
      p1(4) = Eep
C  photon
      egam = YMAx2*ee
      p2(1) = 0.D0
      p2(2) = 0.D0
      p2(3) = egam
      p2(4) = egam
      CALL PHO_SETPAR(1,2212,0,0.D0)
      CALL PHO_SETPAR(2,22,0,0.D0)
      CALL PHO_EVENT(-1,p1,p2,sigmax,irej)
C
      q2low2 = MAX(Q2Min2,hima2*YMIn2**2/(1.D0-YMIn2))
      y2 = YMIn2
      wgmax2 = (1.D0+(1.D0-y2)**2)*LOG(Q2Max2/q2low2)
     &         - 2.D0*hima2*y2*(1.D0/q2low2-1.D0/Q2Max2)*y2
C
      CALL PHO_PHIST(-1,sigmax)
      CALL PHO_LHIST(-1,sigmax)
C
C  generation of events, flux calculation

      ay1 = 0.D0
      ay2 = 0.D0
      ays1 = 0.D0
      ays2 = 0.D0
      q22min = 1.D30
      q22max = 0.D0
      q22ave = 0.D0
      q22av2 = 0.D0
      yy2min = 1.D30
      yy2max = 0.D0
      niter = Nevent
      niters = 0
      itry = 0
      itrw = 0
      DO i = 1 , niter
C  sample photon flux
 150     itry = itry + 1
C
 200     itrw = itrw + 1
C  select Y2
         y2 = EXP(x2del*DT_RNDM(ay2)+x2min)
         q2low2 = MAX(Q2Min2,hima2*y2**2/(1.D0-y2))
         IF ( q2low2.GE.Q2Max2 ) GOTO 200
         q2log2 = LOG(Q2Max2/q2low2)
         wgh = (1.D0+(1.D0-y2)**2)
     &         *q2log2 - 2.D0*hima2*y2*(1.D0/q2low2-1.D0/Q2Max2)*y2
         IF ( LPRi.GT.4 .AND. wgmax2.LT.wgh ) WRITE (LO,'(1X,A,3E12.5)')
     &         'PHO_GHHIAS:WEIGHT ERROR (2):' , y2 , wgmax2 , wgh
         IF ( DT_RNDM(ays1)*wgmax2.GT.wgh ) GOTO 200
C  sample Q2
         IF ( IPAmdl(174).EQ.1 ) THEN
            yeff = 1.D0 + (1.D0-y2)**2
 220        q2p2 = q2low2*EXP(q2log2*DT_RNDM(y2))
            weight = (yeff-2.D0*(1.D0-y2)*q2low2/q2p2)/yeff
            IF ( weight.LT.DT_RNDM(q2p2) ) GOTO 220
         ELSE
            q2p2 = q2low2
         END IF
C  impact parameter
         GAImp(2) = 1.D0/SQRT(q2p2)
C  form factor (squared)
         ff2 = 1.D0
         IF ( GAImp(2).LT.2.D0*hiradi ) ff2 = 0.D0
         IF ( DT_RNDM(q2p2).GE.ff2 ) GOTO 200
C  photon data
         GYY(2) = y2
         GQ2(2) = q2p2

C
C  incoming hadron 1
         PINi(1,1) = 0.D0
         PINi(2,1) = 0.D0
         PINi(3,1) = SQRT(Eep**2-amp2)
         PINi(4,1) = Eep
         PINi(5,1) = amp
C  incoming hadron 2
         PINi(1,2) = 0.D0
         PINi(2,2) = 0.D0
         PINi(3,2) = -SQRT(ee**2-amp2)
         PINi(4,2) = ee
         PINi(5,2) = amp
C  outgoing hadron 2
         yq2 = SQRT((1.D0-y2)*q2p2)
         q2e = q2p2/(4.D0*ee)
         e1y = ee*(1.D0-y2)
         CALL PHO_SFECFE(sif,cof)
         PFIn(1,2) = yq2*cof
         PFIn(2,2) = yq2*sif
         PFIn(3,2) = -e1y + q2e
         PFIn(4,2) = e1y + q2e
         PFIn(5,2) = 0.D0
         PFPhi(2) = ATAN2(cof,sif)
         PFThe(2) = ACOS((q2e-e1y)/(q2e+e1y))
C  scattering hadron
         p1(1) = 0.D0
         p1(2) = 0.D0
         p1(3) = SQRT(Eep**2-amp2)
         p1(4) = Eep
         q2p1 = amp2
C  scattering photon
         p2(1) = -PFIn(1,2)
         p2(2) = -PFIn(2,2)
         p2(3) = PINi(3,2) - PFIn(3,2)
         p2(4) = PINi(4,2) - PFIn(4,2)
         iside = 2
C
C  ECMS cut
         GGEcm = (p1(4)+p2(4))**2 - (p1(1)+p2(1))**2 - (p1(2)+p2(2))
     &           **2 - (p1(3)+p2(3))**2
         IF ( GGEcm.LT.0.1D0 ) GOTO 200
         GGEcm = SQRT(GGEcm)
         IF ( (GGEcm.LT.ECMin) .OR. (GGEcm.GT.ECMax) ) GOTO 200
C
         PGAm(1,1) = p1(1)
         PGAm(2,1) = p1(2)
         PGAm(3,1) = p1(3)
         PGAm(4,1) = p1(4)
         PGAm(5,1) = amp
         PGAm(1,2) = p2(1)
         PGAm(2,2) = p2(2)
         PGAm(3,2) = p2(3)
         PGAm(4,2) = p2(4)
         PGAm(5,2) = -SQRT(q2p2)
C  photon helicities
         IGHel(2) = 1
C  user cuts
         CALL PHO_PRESEL(5,irej)
         IF ( irej.NE.0 ) GOTO 200
C  event generation
         CALL PHO_EVENT(1,p1,p2,sigcur,irej)
         IF (Nprint.LE.10) THEN
            CALL PHO_PREVNT(2)
            Nprint = Nprint + 1
         END IF

         IF ( irej.EQ.0 ) THEN
C  cut on diffractive mass
            DO k = 1 , NHEp
               IF ( ISThep(k).EQ.30 ) THEN
                  ghdiff = PHEp(1,k)
                  IF ( ghdiff.GE.PARmdl(175) ) GOTO 250
                  GOTO 150
               END IF
            END DO
            IF ( LPRi.GT.4 ) WRITE (LO,'(/,1X,A)')
     &            'PHO_GHHIAS: no diffractive entry found'
            CALL PHO_PREVNT(-1)
         END IF
         GOTO 150
C  remove quasi-elastically scattered hadron
 250     DO k = 1 , NHEp
            IF ( (ISThep(k).EQ.1) .AND. (IDHep(k).EQ.2212) ) THEN
               xf = ABS(PHEp(3,k)/Een)
C           ISTHEP(K) = 2
               IF ( xf.LT.PARmdl(72) ) GOTO 150
               GOTO 300
            END IF
         END DO
C
C  statistics

 300     niters = niters + 1

         ay2 = ay2 + y2
         ays2 = ays2 + y2*y2
         q22ave = q22ave + q2p2
         q22av2 = q22av2 + q2p2*q2p2
         q22min = MIN(q22min,q2p2)
         q22max = MAX(q22max,q2p2)
         yy2min = MIN(yy2min,y2)
         yy2max = MAX(yy2max,y2)
C  histograms
         CALL PHO_PHIST(1,HSWght(0))
         CALL PHO_LHIST(1,HSWght(0))
      END DO
C
      wgmax = wgmax2*LOG(YMAx2/YMIn2)
      wgy2 = wgmax*DBLE(itry)/DBLE(MAX(itrw,1))*alpha/(2.D0*PI)
      ay2 = ay2/DBLE(MAX(niters,1))
      ays2 = ays2/DBLE(MAX(niters,1))
      day2 = SQRT((ays2-ay2**2)/DBLE(MAX(niters,1)))
      q22ave = q22ave/DBLE(MAX(niters,1))
      q22av2 = q22av2/DBLE(MAX(niters,1))
      q22av2 = SQRT((q22av2-q22ave**2)/DBLE(MAX(niters,1)))
      wgmax = wgmax2*LOG(YMAx2/YMIn2)
      wgy = wgmax*DBLE(itry)/DBLE(itrw)*alpha/(2.D0*PI)
      weight = wgy*sigmax*DBLE(niter)/DBLE(itry)
C  output of statistics, histograms
      IF ( LPRi.GT.4 ) WRITE (LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &       '========================================================='
     &       , ' *****   simulated cross section: ' , weight ,
     &       ' mb  *****' ,
     &       '========================================================='
      IF ( LPRi.GT.4 ) WRITE (LO,'(//1X,A,/3X,4I12)')
     &        'PHO_GHHIAS:SUMMARY:  NITER,    NITERS,    ITRY,     ITRW'
     &        , niter , niters , itry , itrw
      IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,1P2E12.4)')
     &                         'EFFECTIVE WEIGHT (FLUX,TOTAL)' , wgy ,
     &                        weight
      IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,1P2E12.4)')
     &                         'AVERAGE Y2,DY2               ' , ay2 ,
     &                        day2
      IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,1P2E12.4)')
     &                         'SAMPLED Y RANGE PHOTON 2     ' ,
     &                        yy2min , yy2max
      IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,1P2E12.4)')
     &                         'AVERAGE Q2,DQ2  PHOTON 2     ' ,
     &                        q22ave , q22av2
      IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,1P2E12.4)')
     &                         'SAMPLED Q2 RANGE PHOTON 2    ' ,
     &                        q22min , q22max
C
      CALL PHO_EVENT(-2,p1,p2,weight,irej)
      IF ( niter.GT.1 ) THEN
         CALL PHO_PHIST(-2,weight)
         CALL PHO_LHIST(-2,weight)
      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I4)')
     &         'PHO_GHHIAS: no output of histograms' , niter
      END IF

      END SUBROUTINE


program problem22
  implicit none
  integer, parameter         :: n=5163,m=20
  character(m), dimension(n) :: names
  character(m)               :: temp
  integer                    :: i,j,answer

  open(33,file='./data/problem22.dat')
  read(33,*) names

  ! sort
  do i=1,n
     do j=i,n
        if (names(i) > names(j)) then
           temp=names(i)
           names(i)=names(j)
           names(j)=temp
        end if
     end do
  end do

  answer=0
  do i=1,n
     answer=answer+(i*score(names(i)))
  end do

  print *, answer

contains
  ! score string
  pure function score(name)
    implicit none
    character(m), intent(in) :: name
    integer                  :: score,i

    score=0
    do i=1,len_trim(name)
       score=score+ichar(name(i:i))-ichar('@')
    end do

  end function score

end program problem22


	REAL FUNCTION PR_CLDB  ( ceil, chc1, chc2, chc3 )
C************************************************************************
C* PR_CLDB								*
C*									*
C* This function returns the lowest ceiling from ceil, chc1, chc2 and	*
C* chc3. If there is no ceiling, get the lowest layer from chc1, chc2,	*
C* and chc3.								*
C*									*
C* REAL PR_CLDB  ( CEIL, CHC1, CHC2, CHC3 )				*
C*									*
C* Input parameters:							*
C*	CEIL		REIL		Ceiling in hundreds of feet	*
C*	CHC1		REAL		Cloud height & coverage 1	*
C*	CHC2		REAL		Cloud height & coverage 2	*
C*	CHC3		REAL		Cloud height & coverage 3	*
C*									*
C* Output parameters:							*
C*	PR_CLDB		REAL		The lowest ceiling combined	*
C*					with a numeric cloud coverage	*
C**									*
C* Log:									*
C* M. Li/SAIC		07/06 		Created				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	PR_CLDB = RMISSD
	temp    = RMISSD
C*
	IF  ( .not. ERMISS (ceil) ) THEN
	   IF ( .not. ERMISS (chc1) .and.
     +         ABS ( ceil - INT(chc1/10) ) .lt. RDIFFD )  THEN
	       PR_CLDB = chc1
	     ELSE IF ( .not. ERMISS (chc2) .and.
     +           ABS ( ceil - INT(chc2/10) ) .lt. RDIFFD )  THEN
		 PR_CLDB = chc2
	     ELSE IF ( .not. ERMISS (chc3) .and.
     +           ABS ( ceil - INT(chc3/10) ) .lt. RDIFFD )  THEN
		 PR_CLDB = chc3
	   END IF
C
	   RETURN
	END IF
C
C*	Check the first report.
C*
	IF ( .not. ERMISS (chc1) ) temp = chc1
C
C*	Check 2nd report.
C
	IF ( .not. ERMISS (chc2) .and. .not. ERMISS (chc1)
     +        .and. chc1 .gt. chc2 )
     +      temp = chc2
C
C*	Check 3rd report.
C
	IF ( .not. ERMISS (chc3) .and. .not. ERMISS (temp)
     +        .and. temp .gt. chc3  )
     +      temp = chc3
C*
	IF ( .not. ERMISS (temp) ) PR_CLDB = temp
C*
	RETURN
	END