text:
 module RandomNS
    double precision, dimension(:), allocatable :: C, CD, CM, GSET
    double precision, dimension(:, :), allocatable :: U
    integer, dimension(:), allocatable :: I97, J97, ISET
    integer numNodes

 contains

    subroutine initRandomNS(n, i)
       implicit none
       integer n !no. of nodes
       integer, optional, intent(IN) :: i
       integer kl, ij, k
       integer, dimension(8) :: now
       real :: klr

       !sanity  check
       if (n <= 0) then
          write (*, *) 'you have asked for ', n, 'nodes'
          stop
       endif

       numNodes = n

       !memory allocation
       allocate (C(n), CD(n), CM(n), U(n, 97), I97(n), J97(n), ISET(n), GSET(n))

       ISET = 0

       do k = 1, n
          if (present(i)) then
             kl = 9373
             ij = (i + (k - 1))*45
          else
             call system_clock(count=ij)
             ij = mod(ij, 31328) + (k - 1)*45
             call date_and_time(VALUES = now)
             ! The following could be simplified using all integer arithmetic.
             ! The current implementation is designed to obtain the same rounding
             ! behavior of the earlier implementation, which read the time into
             ! a character array and parsed it with the 'read' statement.
             klr = ((now(5) * 10) + now(6)) * 10 + now(7) + now(8)/1000.0
             kl = mod(int(klr*1000), 30081)
          end if

          call RMARINNS(ij, kl, k)
       enddo
    end subroutine initRandomNS

    subroutine killRandomNS
       deallocate (C, CD, CM, U, I97, J97, ISET, GSET)
    end subroutine killRandomNS

    double precision function GAUSSIAN1NS(idg)
       implicit none
       integer idg, id !node no.
       double precision urv
       double precision R, V1, V2, FAC

       id = idg + 1
       if (ISET(id) == 0) then
          R = 2
          do while (R >= 1.d0)
             urv = ranmarns(id - 1)
             V1 = 2.d0*urv - 1.d0
             urv = ranmarns(id - 1)
             V2 = 2.d0*urv - 1.d0
             R = V1**2 + V2**2
          end do
          FAC = sqrt(-2.d0*log(R)/R)
          GSET(id) = V1*FAC
          gaussian1ns = V2*FAC
          ISET(id) = 1
       else
          gaussian1ns = GSET(id)
          ISET(id) = 0
       endif

    end function GAUSSIAN1NS

    subroutine RMARINNS(IJ, KL, id)
! This is the initialization routine for the randomNS number generator ranmarns()
! NOTE: The seed variables can have values between:    0 <= IJ <= 31328
!                                                      0 <= KL <= 30081
!The randomNS number sequences created by these two seeds are of sufficient
! length to complete an entire calculation with. For example, if sveral
! different groups are working on different parts of the same calculation,
! each group could be assigned its own IJ seed. This would leave each group
! with 30000 choices for the second seed. That is to say, this randomNS
! number generator can create 900 million different subsequences -- with
! each subsequence having a length of approximately 10^30.
!
! Use IJ = 1802 & KL = 9373 to test the randomNS number generator. The
! subroutine ranmarns should be used to generate 20000 randomNS numbers.
! Then display the next six randomNS numbers generated multiplied by 4096*4096
! If the randomNS number generator is working properly, the randomNS numbers
!    should be:
!           6533892.0  14220222.0  7275067.0
!           6172232.0  8354498.0   10633180.0

       if (IJ < 0) IJ = 31328 + IJ
       if (IJ > 31328) IJ = mod(IJ, 31328)
       if (KL < 0) KL = 30081 + KL
       if (KL > 30081) KL = mod(KL, 30081)

       if (IJ < 0 .or. IJ > 31328 .or. KL < 0 .or. KL > 30081) then
          print '(A)', ' The first randomNS number seed must have a value  between 0 and 31328'
          print '(A)', ' The second seed must have a value between 0 and   30081'
          stop
       endif
       I = mod(IJ/177, 177) + 2
       J = mod(IJ, 177) + 2
       K = mod(KL/169, 178) + 1
       L = mod(KL, 169)
       do II = 1, 97
          S = 0.0
          T = 0.5
          do JJ = 1, 24
             M = mod(mod(I*J, 179)*K, 179)
             I = J
             J = K
             K = M
             L = mod(53*L + 1, 169)
             if (mod(L*M, 64) >= 32) S = S + T
             T = 0.5*T
          enddo
          U(id, II) = S
       enddo
       C(id) = 362436.0/16777216.0
       CD(id) = 7654321.0/16777216.0
       CM(id) = 16777213.0/16777216.0
       I97(id) = 97
       J97(id) = 33

    end subroutine RMARINNS

    double precision function ranmarns(idg)
! This is the random number generator proposed by George Marsaglia in
! Florida State University Report: FSU-SCRI-87-50
! It was slightly modified by F. James to produce an array of pseudorandom
! numbers.

       id = idg + 1

       UNI = U(id, I97(id)) - U(id, J97(id))
       if (UNI < 0.) UNI = UNI + 1.
       U(id, I97(id)) = UNI
       I97(id) = I97(id) - 1
       if (I97(id) == 0) I97(id) = 97
       J97(id) = J97(id) - 1
       if (J97(id) == 0) J97(id) = 97
       C(id) = C(id) - CD(id)
       if (C(id) < 0.) C(id) = C(id) + CM(id)
       UNI = UNI - C(id)
       if (UNI < 0.) UNI = UNI + 1. ! bug?
       ranmarns = UNI

    end function ranmarns

 end module RandomNS

max_stars_repo_name: annis/cosmosis

max_issues_repo_name: annis/cosmosis

max_forks_repo_name: annis/cosmosis


module flags_M

implicit none

!---Flags
    integer :: feedback_method = 0
    real :: save_time_interval
    integer :: td_method_type = 0
    logical :: DEBUG = .FALSE.
    logical :: steady_state_flag = .TRUE.
    logical :: unit_test = .FALSE.
    logical :: unit_test_2 = .FALSE.
    logical :: nonlinear_ss_flag
    logical :: lagrange = .FALSE.
    logical :: hermite = .TRUE.
    logical :: transient
    logical :: transient_save_flag = .FALSE.
    logical :: ramp_flag = .FALSE.
    logical :: step_flag = .FALSE.
    logical :: zag_flag = .FALSE.
    logical :: read_power_from_file = .FALSE.
    logical :: Read_DIF3D = .FALSE.
    logical :: End_Event
    logical :: BetaFeedback
    logical :: nl_iter_flag = .TRUE.

    logical :: temperature_converged = .FALSE.

    logical :: MSRE_problem = .FALSE.
end module flags_M


text:
!-----------------------------------------------------------------------
! CUDA Fortran GPU Tutorial: Copy
! written by Viktor K. Decyk, UCLA
      program example1
      use copy
      use gpuflib2
      implicit none
! nx, ny = size of array
      integer, parameter :: nx = 3000, ny = 600
! nblock = block size on GPU
      integer :: nblock = 64
! mx, my = data block size
      integer :: mx, my
      real :: s = 0.5
      integer :: j, k, irc
      real :: eps, epsmax
! timing data
      double precision :: dtime
      integer, dimension(4) :: itime
! data for Fortran Host
      real, dimension(nx) :: a1, b1
      real, dimension(nx,ny) :: a2, b2
! data for GPU
      real, device, dimension(:), allocatable :: g_a1, g_b1
      real, device, dimension(:,:), allocatable :: g_a2, g_b2
!
! set up GPU
      irc = 0
      call setgbsize(nblock)
      call init_cu(0,irc)
      if (irc /= 0) then
         write (*,*) 'CUDA initialization error!'
         stop
      endif
!
! allocate 1d data on GPU
      allocate(g_a1(nx),g_b1(nx))
!
! allocate 2d data on GPU
      allocate(g_a2(nx,ny),g_b2(nx,ny))
!
! initialize 1d data on Host
      do j = 1, nx
         b1(j) = real(j)
      enddo
      a1 = 0.0
! initialize 2d data on Host
      do k = 1, ny
      do j = 1, nx
         b2(j,k) = real(j + nx*(k-1))
      enddo
      enddo
      a2 = 0.0
! copy data to GPU
      g_a1 = a1
      g_b1 = b1
      g_a2 = a2
      g_b2 = b2
!
! measure overhead time by running empty kernel
      call dtimer(dtime,itime,-1)
      call empty_kernel()
      call dtimer(dtime,itime,1)
      write (*,*) 'Fortran empty kernel time=', real(dtime)
!
! 1D copy
      mx = 128
!
! segmented 1d copy on Host with block size mx
      call dtimer(dtime,itime,-1)
!     call copy0(a1,b1)
      call copy1(a1,b1,mx)
      call dtimer(dtime,itime,1)
      write (*,*) 'Fortran 1d copy time=', real(dtime)
!
! 1d copy on GPU with block size mx
      call dtimer(dtime,itime,-1)
      call gpu_copy1(g_a1,g_b1,mx)
      call dtimer(dtime,itime,1)
      write (*,*) 'GPU 1d copy time=', real(dtime)
!
! copy data from GPU
      b1 = g_a1
!
! Check for correctness: compare a1 and g_a1
      epsmax = 0.0
      do j = 1, nx
         eps = abs(a1(j)-b1(j))
         if (eps > epsmax) epsmax = eps
      enddo
      write (*,*) '1d copy maximum difference = ', epsmax
!
! 2D copy
      mx = 16; my = 16
!
! segmented 2d copy on host with block size mx, my
      call dtimer(dtime,itime,-1)
!     call copy2(a2,b2,mx)
!     call saxpy2(a2,b2,s,mx)
      call copy3(a2,b2,mx,my)
      call dtimer(dtime,itime,1)
      write (*,*) 'Fortran 2d copy time=', real(dtime)
!
! 2d copy on GPU with block size mx, my
      call dtimer(dtime,itime,-1)
!     call gpu_copy2a(g_a2,g_b2,mx)
!     call gpu_copy2b(g_a2,g_b2,mx)
!     call gpu_saxpy2(g_a2,g_b2,s,mx)
      call gpu_copy3(g_a2,g_b2,mx,my)
      call dtimer(dtime,itime,1)
      write (*,*) 'GPU 2d copy time=', real(dtime)
!
! copy data from GPU
      b2 = g_a2
!
! Check for correctness: compare a2 and g_a2
      epsmax = 0.0
      do k = 1, ny
         do j = 1, nx
            eps = abs(a2(j,k)-b2(j,k))
            if (eps > epsmax) epsmax = eps
         enddo
      enddo
      write (*,*) '2d copy maximum difference = ', epsmax
!
! deallocate memory on GPU
      deallocate(g_a1,g_b1)
      deallocate(g_a2,g_b2)
! close down GPU
      call end_cu()
!
      end program

max_stars_repo_name: gcasabona/cuda

max_issues_repo_name: gcasabona/cuda

max_forks_repo_name: gcasabona/cuda


text:
! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

!> Should only have fortran "kinds".  the constants should
!> go into their own module, or this should be renamed 'constants'
!> or something more descriptive than 'types' (which overlaps
!> into our obs kinds and types).

module types_mod

implicit none
private

public :: i2, i4, i8, r4, c4, r8, c8, digits12
public :: PI, DEG2RAD, RAD2DEG, MISSING_R4, MISSING_R8
public :: MISSING_I, MISSING_I8, MISSING_DATA
public :: SECPERDAY
public :: t_kelvin, es_alpha, es_beta, es_gamma, gas_constant_v, gas_constant
public :: L_over_Rv, ps0, earth_radius, gravity
public :: metadatalength, obstypelength, varnamelength, vtablenamelength
public :: MAX_NUM_DOMS, MAX_FILES

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

!----------------------------------------------------------------------------
! constants that need to be shared - really has nothing to do with types ...
!----------------------------------------------------------------------------

integer, parameter :: metadatalength   = 64   ! 75 is max w/out wrapping in ncdump
integer, parameter :: varnamelength    = 31   ! max name of any fortran variable
                                              ! in F90/95. increased to 63 in F2003
integer, parameter :: obstypelength    = 31   ! because of variable name limits.
                                              ! use this for obs types/kinds
integer, parameter :: vtablenamelength = 64   ! use this for the model_mod variable table items

integer, parameter :: MAX_NUM_DOMS     = 10   ! max num domains. this is arbitrarily
                                              ! based on WRF's maximum number of domains

integer, parameter :: MAX_FILES        = 1000 ! maximum number of files

!----------------------------------------------------------------------------
! Attributes for variable kinds -- declaring sizes explicitly means we know
! exactly what precision we are using and are not relying on compiler flags
! to set the defaults for real and int.
!
! (this block of text is originally from the MPI documentation but it seems to apply
! to the compiler intrinsic functions SELECTED_REAL_KIND and SELECTED_INT_KIND)
!
! for reals, SELECTED_REAL_KIND(p, r) values result in:
!
!   if      (p > 33) or (r > 4931) then  external32 representation
!                                        is undefined
!   else if (p > 15) or (r >  307) then  external32_size = 16
!   else if (p >  6) or (r >   37) then  external32_size =  8
!   else                                 external32_size =  4
!
!
! for integers, SELECTED_INT_KIND(r) results in:
!
!   if      (r > 38) then  external32 representation is undefined
!   else if (r > 18) then  external32_size =  16
!   else if (r >  9) then  external32_size =  8
!   else if (r >  4) then  external32_size =  4
!   else if (r >  2) then  external32_size =  2
!   else                   external32_size =  1
!
!----------------------------------------------------------------------------

! integer precision:
integer, parameter :: i2 = SELECTED_INT_KIND(3)
integer, parameter :: i4 = SELECTED_INT_KIND(8)
integer, parameter :: i8 = SELECTED_INT_KIND(13)

! real precision:
! TO RUN WITH REDUCED PRECISION REALS (and use correspondingly less memory)
! comment OUT the r8 definition below and use the second one:
integer, parameter :: r4 = SELECTED_REAL_KIND(6,30)
integer, parameter :: r8 = SELECTED_REAL_KIND(12)   ! 8 byte reals
!integer, parameter :: r8 = r4                      ! alias r8 to r4

! complex precision:
integer, parameter :: c4 = SELECTED_REAL_KIND(6,30)
integer, parameter :: c8 = SELECTED_REAL_KIND(12)

! 'digits12' is reserved for real variables that MUST retain 64 bits of
! precision. DO NOT CHANGE '12' to a smaller number. BAD BAD BAD things happen.
! This is a small subset of the variables. Changing this will ruin the ability
! to distinguish timesteps that are a few seconds apart, for instance.

integer, parameter :: digits12 = SELECTED_REAL_KIND(12)

!----------------------------------------------------------------------------
! Constants, some of which are model dependent and shouldn't be in this
! module.
!----------------------------------------------------------------------------

integer,       parameter ::  SECPERDAY = 24*60*60

real(kind=r8), parameter :: PI = 3.14159265358979323846_r8
real(kind=r8), parameter :: DEG2RAD = PI / 180.0_r8
real(kind=r8), parameter :: RAD2DEG = 180.0_r8 / PI

integer,          parameter ::  MISSING_I    = -888888
integer(kind=i8), parameter ::  MISSING_I8   = -888888_I8
integer,          parameter ::  MISSING_DATA = -88
real(kind=r4),    parameter ::  MISSING_R4   = -888888.0_r4
real(kind=r8),    parameter ::  MISSING_R8   = -888888.0_r8

real(r8), parameter :: t_kelvin       = 273.15_r8
real(r8), parameter :: es_alpha       = 611.2_r8
real(r8), parameter :: es_beta        = 17.67_r8
real(r8), parameter :: es_gamma       = 243.5_r8
real(r8), parameter :: gas_constant_v = 461.6_r8
real(r8), parameter :: gas_constant   = 287.0_r8 ! wikipedia has 287.06, WRF has 287.05 ...
real(r8), parameter :: L_over_Rv      = 5418.12_r8
real(r8), parameter :: ps0            = 100000.0_r8    ! Base sea level pressure
real(r8), parameter :: earth_radius   = 6370.0_r8      ! km, consistant with WRF
real(r8), parameter :: gravity        = 9.81_r8        ! wikipedia has 9.80665

end module types_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$

max_stars_repo_name: hkershaw-brown/feature-preprocess

max_issues_repo_name: hkershaw-brown/feature-preprocess

max_forks_repo_name: hkershaw-brown/feature-preprocess


text:
      SUBROUTINE E04156 (USEPRM)

C   E04156 tests the handling of error 156.

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /ERRINF/ ERRCOM,FUNCOM,FILCOM, ERNMSW, EXPSIZ,EXPERR,
     1                USRERR, ERRSAV,      FUNSAV,      FILSAV,
     2                EFCNT, EFID
      INTEGER         ERRCOM,FUNCOM,FILCOM, ERNMSW, EXPSIZ,EXPERR(10),
     1                USRERR, ERRSAV(200), FUNSAV(200), FILSAV(200),
     2                EFCNT, EFID(100)
      COMMON /ERRCHR/ CURCON,     ERRSRS,    ERRMRK,    ERFLNM,
     1                CONTAB
      CHARACTER       CURCON*200, ERRSRS*40, ERRMRK*20, ERFLNM*80,
     1                CONTAB(40)*150

      INTEGER    USEPRM, ISIZ,IDUM1
      REAL       WKWN(6),WKWN0(6),WKWN1(6),WKWN4(4)
      REAL       RDUMA(6),RDUMB(6),RDUMC(6),RDUMD(4),RDUME(4),RDUMF(4)
      LOGICAL    STREQ, RAREQ, APPEQ

      CURCON = 'the specified workstation window limits are not ' //
     1         'within NPC range'
      CALL SETVS ('156', EXPERR, EXPSIZ)
      ERRSRS = '6'
      CALL ESETUP (USEPRM)

      CALL POPWK (WKID, CONID, WTYPE)

C  3D
      CALL SETRVS ('.1,.9,.1,.9,.1,.9', WKWN0, ISIZ)
      CALL PSWKW3 (WKID, WKWN0)

      CALL SETRVS ('-.1,1.,0.,1.,0.,1.', WKWN, ISIZ)
      CALL RSWKW3 (WKID, WKWN)
      CALL SETRVS ('0.,1.,0.,1.1,0.,1.', WKWN, ISIZ)
      CALL RSWKW3 (WKID, WKWN)
      CALL SETRVS ('0.,1.,0.,1.,-0.1,1.1', WKWN, ISIZ)
      CALL RSWKW3 (WKID, WKWN)

      CALL PQWKT3 (WKID,ERRIND,IDUM1, WKWN1,RDUMA,RDUMB,RDUMC)
      CALL CHKINQ ('pqwkt3', ERRIND)
      CALL TSTIGN (STREQ('OO**') .AND. RAREQ(6,WKWN0,WKWN1,0.01,0.01))

C  2D
      CALL PSWKW (WKID, 0.1,0.9,0.1,0.9)

      CALL RSWKW (WKID, -0.1,1.,0.,1.)
      CALL RSWKW (WKID, 0.1,1.,0.,1.1)
      CALL RSWKW (WKID, -0.1,1.,0.,1.1)

      CALL PQWKT (WKID, ERRIND,IDUM1,WKWN4,RDUMD,RDUME,RDUMF)
      CALL CHKINQ ('pqwkt',ERRIND)
      CALL TSTIGN (STREQ('OO**')       .AND.
     1             APPEQ(WKWN4(1) , 0.1,0.01,0.01) .AND.
     2             APPEQ(WKWN4(2) , 0.9,0.01,0.01) .AND.
     3             APPEQ(WKWN4(3) , 0.1,0.01,0.01) .AND.
     4             APPEQ(WKWN4(4) , 0.9,0.01,0.01))

      CALL PCLWK (WKID)

      CALL ENDERR

      END

ext: f


text:
program test_64_bit_hash_performance
!! Program to compare the relative performance of different 64 bit hash
!! functions

    use stdlib_kinds, only: &
        dp,           &
        int8,         &
        int32,        &
        int64

    use stdlib_hash_64bit

    implicit none

    integer, parameter :: &
        block_size(8) = [ 1, 2, 4, 8, 16, 64, 256, 1024 ]
    integer(int32), parameter :: huge32 = huge(0_int32)
    real(dp), parameter :: hugep1 = real(huge32, dp) + 1.0_dp
    integer, parameter :: rand_power = 16
    integer, parameter :: rand_size = 2**rand_power
    integer, parameter :: test_size = rand_size * 4
    integer, parameter :: repeat = 4
    integer :: index, k
    integer :: lun
    real(dp) :: rand(2)
    integer(int32) :: rand_object(rand_size)
    integer(int8) :: test_object(test_size)

    open( newunit=lun, file="64_bit_hash_performance_log.txt", &
          access="sequential", action="write", form="formatted", &
          position="rewind" )

    do index=1, rand_size
        call random_number(rand)
        if (rand(1) < 0.5_dp) then
            rand_object(index) = ceiling(-rand(2)*hugep1, int32) - 1
        else
            rand_object(index) = floor(rand(2)*hugep1, int32)
        end if
    end do

    test_object(:) = transfer( rand_object, 0_int8, test_size )

    write(lun, '("| Algorithm  | Key Size  | Key #      | Time (s) |")')
    write(lun, '("|            | Bytes     |            |          |")')
    write(lun, '("|------------|-----------|------------|----------|")')

    call test_fnv_1()

    call test_fnv_1a()

    call test_pengy()

    call test_spooky()

contains

    subroutine test_fnv_1()
        integer :: index2
        integer(int64) :: hash
        real :: t1, t2, tdiff
        integer(int64) :: summary(repeat)

        do k=1, size(block_size)
            call cpu_time(t1)
            do index=1, repeat
                do index2=1, test_size, block_size(k)
                    hash = fnv_1_hash( test_object( index2: &
                                                    index2+block_size(k)-1 ) )
                    if (index2 == index) summary(index) = hash
                end do
            end do
            call cpu_time(t2)
            tdiff = t2-t1
            write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
                '"|", f9.5, 1x, "|")') 'FNV-1', &
                block_size(k), repeat*(test_size/block_size(k)), tdiff
        end do

    end subroutine test_fnv_1

    subroutine test_fnv_1a()
        integer :: index2
        integer(int64) :: hash
        real :: t1, t2, tdiff
        integer(int64) :: summary(repeat)

        do k=1, size(block_size)
            call cpu_time(t1)
            do index=1, repeat
                do index2=1, test_size, block_size(k)
                    hash = fnv_1a_hash( test_object( index2: &
                                                     index2+block_size(k)-1 ) )
                    if (index2 == index) summary(index) = hash
                end do
            end do
            call cpu_time(t2)
            tdiff = t2-t1
            write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
                '"|", f9.5, 1x, "|")') 'FNV-1a', &
                block_size(k), repeat*(test_size/block_size(k)), tdiff
        end do

    end subroutine test_fnv_1a

    subroutine test_spooky()
        integer :: index2
        integer(int64) :: hash(2)
        integer(int64) :: seed(2) = [ 0_int64, 0_int64 ]
        real :: t1, t2, tdiff
        integer(int64) :: summary(repeat)

        call new_spooky_hash_seed( seed )
        do k=1, size(block_size)
            call cpu_time(t1)
            do index=1, repeat
                do index2=1, test_size, block_size(k)
                    hash = spooky_hash( test_object( index2: &
                                                     index2+block_size(k)-1 ), &
                                                     seed )
                    if (index2 == index) summary(index) = hash(1)
                end do
            end do
            call cpu_time(t2)
            tdiff = t2-t1
            write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
                '"|", f9.5, 1x, "|")') 'Spooky', &
                block_size(k), repeat*(test_size/block_size(k)), tdiff
        end do

    end subroutine test_spooky

    subroutine test_pengy()
        integer :: index2
        integer(int64) :: hash
        integer(int32) :: seed = int( z'DEADBEEF', int32 )
        real :: t1, t2, tdiff
        integer(int64) :: summary(repeat)

        call new_pengy_hash_seed( seed )
        do k=1, size(block_size)
            call cpu_time(t1)
            do index=1, repeat
                do index2=1, test_size, block_size(k)
                    hash = pengy_hash( test_object( index2: &
                                       index2+block_size(k)-1 ), &
                                       seed )
                    if (index2 == index) summary(index) = hash
                end do
            end do
            call cpu_time(t2)
            tdiff = t2-t1
            write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
                '"|", f9.5, 1x, "|")') 'Pengy', &
                block_size(k), repeat*(test_size/block_size(k)), tdiff
        end do

    end subroutine test_pengy

end program test_64_bit_hash_performance

max_stars_repo_name: freevryheid/stdlib

max_issues_repo_name: freevryheid/stdlib

max_forks_repo_name: freevryheid/stdlib


text:
      subroutine merge_shifts_ho(irr,mitot,mjtot,lwidth,hx,hy,xlow,ylow,
     . lstgrd, ssw)
  !   INPUTS:
  !   REQUIRED GRID DATA
  !
  !   irr,mitot,mjtot,lwidth,hx,hy,xlow,ylow,lstgrd
  !
  !
  !   OUTPUT
  !   volmerge_ho, xcentmerge_ho, ycentmerge_ho, qmshifts_ho

  !   NOTE qmshifts_ho(1,kirr) = shift for xx
  !        qmshifts_ho(2,kirr) = shift for xy
  !        qmshifts_ho(3,kirr) = shift for yy
  !        qmshifts_ho(4,kirr) = shift for xxx
  !        qmshifts_ho(5,kirr) = shift for xxy
  !        qmshifts_ho(6,kirr) = shift for xyy
  !        qmshifts_ho(7,kirr) = shift for yyy

      implicit double precision (a-h, o-z)
      include "cirr.i"
      include "quadrature.i"
      dimension irr(mitot,mjtot)

          qmshifts_ho = 0.d0
          volMerge_ho = 0.d0
          xcentmerge_ho = 0.d0
          ycentmerge_ho = 0.d0

      ar_ho(lstgrd) = hx*hy
      ! compute xcmerge, ycmerge, volmerge
      do 30 j = lwidth+1, mjtot-lwidth
      do 30 i = lwidth+1, mitot-lwidth
         k = irr(i,j)

         if(k .eq. -1 .or. k .eq. lstgrd) goto 30

!         tv = 0.d0
!         xct = 0.d0
!         yct = 0.d0

         do 20 ic = 1, ncount(k)
            icurr = iidx(k,ic)
            jcurr = jidx(k,ic)
            kcurr = irr(icurr,jcurr)

            if (kcurr .eq. lstgrd) then
               xc = xlow + (icurr-0.5d0)*hx
               yc = ylow + (jcurr-0.5d0)*hy
            else
               xc = xcirr_ho(kcurr)
               yc = ycirr_ho(kcurr)
            endif

            volMerge_ho(k) = volMerge_ho(k)
     .                    +    ar_ho(kcurr) / numHoods(icurr,jcurr)
            xcentmerge_ho(k) = xcentmerge_ho(k)
     .                    + xc*ar_ho(kcurr) / numHoods(icurr,jcurr)
            ycentmerge_ho(k) = ycentmerge_ho(k)
     .                    + yc*ar_ho(kcurr) / numHoods(icurr,jcurr)

!            tv = tv  +    ar(kcurr) / numHoods(icurr,jcurr)
!            xct = xct+ xc*ar(kcurr) / numHoods(icurr,jcurr)
!            yct = yct+ yc*ar(kcurr) / numHoods(icurr,jcurr)

 20      continue

         xcentmerge_ho(k) = xcentmerge_ho(k) / volMerge_ho(k)
         ycentmerge_ho(k) = ycentmerge_ho(k) / volMerge_ho(k)

!          xct = xct / tv
!         yct = yct / tv
 30   continue

      ! recompute the shifts
      do 719 j = lwidth+1, mjtot-lwidth ! iterate over each cell in the grid
      do 719 i = lwidth+1, mitot-lwidth ! iterate over each cell in the grid
       kirr = irr(i,j)

       if (kirr .eq. -1 .or. kirr .eq. lstgrd) cycle ! skip solid and whole cells

           shiftmxx  = 0.d0
           shiftmxy  = 0.d0
           shiftmyy  = 0.d0
           shiftmxxx = 0.d0
           shiftmxxy = 0.d0
           shiftmxyy = 0.d0
           shiftmyyy = 0.d0

           x0 = xcentmerge_ho(kirr)
           y0 = ycentmerge_ho(kirr)

           arr = volmerge_ho(kirr)

      do 340 ic = 1, ncount(kirr) ! iterate over each cell in the neighborhood
            ioff = iidx(kirr,ic)
            joff = jidx(kirr,ic)

            koff = irr(ioff, joff)

      if(koff .eq. lstgrd) then ! full cell
            x1 = xlow + (dfloat(ioff)-1.d0)*hx
            y1 = ylow + (dfloat(joff)-1.d0)*hy

            x3 = xlow + (dfloat(ioff)-0.d0)*hx
            y3 = ylow + (dfloat(joff)-0.d0)*hy

            ! YOU MUST WEIGHT THE QUADRILATERAL AREA BY NUMHOODS
            arcell = hx * hy / numHoods(ioff, joff)

      do 11 iq = 1, nquadquad
          xval = x1 * (1.d0 - rquad(iq))/2. + x3 * (1.d0 + rquad(iq))/2.
          yval = y1 * (1.d0 - squad(iq))/2. + y3 * (1.d0 + squad(iq))/2.

      shiftmxx = shiftmxx + (arcell/arr)*wquad(iq)*((xval-x0)/hx)**2

      shiftmxy = shiftmxy
     .       + (arcell/arr)*wquad(iq)*((xval-x0)/hx)*((yval-y0)/hy)

      shiftmyy = shiftmyy + (arcell/arr)*wquad(iq)*((yval-y0)/hy)**2

      shiftmxxx = shiftmxxx
     .       + (arcell/arr)*wquad(iq)*(xval-x0)**3 /(hx**3)
      shiftmxxy = shiftmxxy
     .       + (arcell/arr)*wquad(iq)*(yval-y0)*(xval-x0)**2/(hx*hx*hy)
      shiftmxyy = shiftmxyy
     .       + (arcell/arr)*wquad(iq)*(xval-x0)*(yval-y0)**2/(hx*hy*hy)
      shiftmyyy = shiftmyyy
     .       + (arcell/arr)*wquad(iq)*(yval-y0)**3/(hy**3)
 11         continue ! for each quadrature point on full cell

      else                      ! cut cells

          ivert = 1
          do 239 while (poly(ivert+1,1,koff) .ne. -11.)
            ivert = ivert + 1
 239     continue

          itri = ivert - 3
          idx1 = 1

          do 219 it = 1, itri-1 ! for each  triangle except the last one
            idx2 = it + 1
            idx3 = it + 2

            x1 = poly(idx1,1,koff)
            y1 = poly(idx1,2,koff)

            x2 = poly(idx2,1,koff)
            y2 = poly(idx2,2,koff)

            x3 = poly(idx3,1,koff)
            y3 = poly(idx3,2,koff)

            ! YOU MUST WEIGHT THE TRIANGLE AREA BY NUMHOODS
            artri = tri_area(x1, x2, x3,
     .                            y1, y2, y3) / numHoods(ioff, joff)

            do 229 itq = 1,ntriquad

                xval = x1 * rtri(itq) + x2 * stri(itq)
     .              +  x3 * (1.d0-rtri(itq)-stri(itq))
                yval = y1 * rtri(itq) + y2 * stri(itq)
     .              +  y3 * (1.d0-rtri(itq)-stri(itq))

      shiftmxx = shiftmxx + (artri/arr)*wtri(itq)*(xval-x0)**2 /(hx**2)
      shiftmxy = shiftmxy
     .          + (artri/arr)*wtri(itq)*(xval-x0)*(yval-y0)/(hx * hy)
      shiftmyy = shiftmyy + (artri/arr)*wtri(itq)*(yval-y0)**2 /(hy**2)

      shiftmxxx = shiftmxxx
     .                   + (artri/arr)*wtri(itq)*(xval-x0)**3 /(hx**3)
      shiftmxxy = shiftmxxy
     .        + (artri/arr)*wtri(itq)*(yval-y0)*(xval-x0)**2/(hy*hx**2)
      shiftmxyy = shiftmxyy
     .        + (artri/arr)*wtri(itq)*(xval-x0)*(yval-y0)**2 /(hx*hy**2)
      shiftmyyy = shiftmyyy
     .        + (artri/arr)*wtri(itq)*(yval-y0)**3 /(hy**3)

 229      continue ! for each quadrature point on each triangle
 219      continue ! for each triangle
      if(ssw .eq. 2  .or. ssw .eq. -2) then
      x1 = poly(ivert-2,1,koff)
      y1 = poly(ivert-2,2,koff)

      x2 = bdry(1,1,koff)
      y2 = bdry(1,2,koff)

      x3 = bdry(3,1,koff)
      y3 = bdry(3,2,koff)

      x4 = bdry(2,1,koff)
      y4 = bdry(2,2,koff)

      do nq = 1,ntriquad_ho
      artri = dJ2(x1,x2,x3,x4,y1,y2,y3,y4,nq)/ numHoods(ioff, joff)

      xval = rs2xy_2(x1,x2,x3,x4,nq)
      yval = rs2xy_2(y1,y2,y3,y4,nq)

      shiftmxx = shiftmxx
     .          + (artri/arr)*wtri_ho(nq)*(xval-x0)**2 /(hx**2)
      shiftmxy = shiftmxy
     .          + (artri/arr)*wtri_ho(nq)*(xval-x0)*(yval-y0)/(hx * hy)
      shiftmyy = shiftmyy
     .          + (artri/arr)*wtri_ho(nq)*(yval-y0)**2 /(hy**2)

      shiftmxxx = shiftmxxx +
     .     (artri/arr)*wtri_ho(nq)*(xval-x0)**3 /(hx**3)
      shiftmxxy = shiftmxxy +
     .     (artri/arr)*wtri_ho(nq)*(yval-y0)*(xval-x0)**2 /(hy*hx**2)
      shiftmxyy = shiftmxyy +
     .     (artri/arr)*wtri_ho(nq)*(xval-x0)*(yval-y0)**2 /(hx*hy**2)
      shiftmyyy =shiftmyyy
     .   + (artri/arr)*wtri_ho(nq)*(yval-y0)**3 /(hy**3)

      enddo
      elseif(ssw .eq. 3 .or. ssw .eq. -3) then
      x1 = poly(ivert-2,1,koff)
      y1 = poly(ivert-2,2,koff)

      x2 = bdry(1,1,koff)
      y2 = bdry(1,2,koff)

      x3 = bdry(4,1,koff)
      y3 = bdry(4,2,koff)

      x4 = bdry(2,1,koff)
      y4 = bdry(2,2,koff)

      x5 = bdry(3,1,koff)
      y5 = bdry(3,2,koff)

      do nq = 1,ntriquad_ho
      artri = dJ3(x1,x2,x3,x4,x5,y1,y2,y3,y4,y5,nq)/ numHoods(ioff,joff)

      xval = rs2xy_3(x1,x2,x3,x4,x5,nq)
      yval = rs2xy_3(y1,y2,y3,y4,y5,nq)

      shiftmxx = shiftmxx
     .       + (artri/arr)*wtri_ho(nq)*(xval-x0)**2 /(hx**2)
      shiftmxy = shiftmxy
     .       + (artri/arr)*wtri_ho(nq)*(xval-x0)*(yval-y0)/(hx * hy)
      shiftmyy = shiftmyy
     .       + (artri/arr)*wtri_ho(nq)*(yval-y0)**2 /(hy**2)

      shiftmxxx = shiftmxxx
     .     + (artri/arr)*wtri_ho(nq)*(xval-x0)**3 /(hx**3)
      shiftmxxy = shiftmxxy
     .     + (artri/arr)*wtri_ho(nq)*(yval-y0)*(xval-x0)**2 /(hy*hx**2)
      shiftmxyy = shiftmxyy
     .     + (artri/arr)*wtri_ho(nq)*(xval-x0)*(yval-y0)**2 /(hx*hy**2)
      shiftmyyy =shiftmyyy
     .     + (artri/arr)*wtri_ho(nq)*(yval-y0)**3 /(hy**3)

      end do

      endif

      endif
 340     continue  ! iterate over each cell in the neighborhood

           qmshifts_ho(1,kirr)  = shiftmxx
           qmshifts_ho(2,kirr)  = shiftmxy
           qmshifts_ho(3,kirr)  = shiftmyy
           qmshifts_ho(4,kirr)  = shiftmxxx
           qmshifts_ho(5,kirr)  = shiftmxxy
           qmshifts_ho(6,kirr)  = shiftmxyy
           qmshifts_ho(7,kirr)  = shiftmyyy

 719      continue ! iterate over each cell in the grid

      end

 !    computes the area of the triangle with the vertices
 !    (x1,y1), (x2,y2), (x3,y3)
      double precision function tri_area(x1, x2, x3, y1, y2, y3)
      implicit double precision (a-h,o-z)

      tri_area = dabs(0.5d0 * ( (x2 - x1) * (y3 - y1)
     .                    - (x3 - x1) * (y2 - y1) ))

      return
      end


text:
!-------------------------------
      subroutine open_namelist (lun)
      implicit none
      integer lun
      character*255 filename

      lun = 10
      filename = 'wrfsi.nl'
      open(lun,file=filename,status='old',err=900)
      return

 900  print*,'error opening namelist file ', filename
      stop

      end

!-----------------------------
      subroutine read_wrfsi_project_id (istatus)

      implicit none

      include 'wrf_projname.cmn'
      include 'grid_fname.cmn'
      integer lenr
      integer istatus

      integer iflag_simname_cmn
      data iflag_simname_cmn/0/
      save iflag_simname_cmn

      character*255 filename
      character*80 simulation_name
      character*80 user_desc

      namelist /project_id/ simulation_name,user_desc

      istatus = 0
      call s_len(generic_data_root,lenr)
      filename = generic_data_root(1:lenr)//'/static/wrfsi.nl'
      if(iflag_simname_cmn.ne.1)then
         open(93,file=filename,status='old',err=900)
         rewind(93)
         read(93,project_id,err=901)
         close(93)
         iflag_simname_cmn=1
         simulation_name_cmn=simulation_name
      endif
      istatus = 1
      return

 900  print*,'error opening namelist file ', filename
      return

 901  print*,'error reading', filename(1:8),' for project_id'
      write(*,project_id)
      return

      end

!-------------------------------
      subroutine read_wrfsi_filetimespec (lun,
     +            fname, ftype, order,
     +            start_year, start_month, start_day, start_hour,
     +            end_year, end_month, end_day, end_hour, interval)

      implicit none
      integer lun

      character*255 fname
      character*80 ftype
      character*80 order
      integer start_year, start_month, start_day, start_hour
      integer end_year, end_month, end_day, end_hour, interval

      namelist /filetimespec/
     +            fname,
     +            start_year, start_month, start_day, start_hour,
     +            end_year, end_month, end_day, end_hour, interval,
     +            ftype, order

      rewind(lun)
      read(lun,filetimespec,err=901)
      return

 901  print*,'error reading namelist file for filetimespec'
      write(*,filetimespec)
      stop
      end

!-------------------------------
      subroutine read_wrfsi_hgridspec (istatus)

      implicit none

      include 'wrf_horzgrid.cmn'
      include 'grid_fname.cmn'

      character*255 filename

      integer      istatus
      integer      iflag_horzgrid_cmn
      data         iflag_horzgrid_cmn/0/
      save         iflag_horzgrid_cmn

      integer      lenr

      namelist /hgridspec/
     +          num_domains,xdim,ydim,parent_id
     +         ,ratio_to_parent
     +         ,domain_origin_lli
     +         ,domain_origin_llj
     +         ,domain_origin_uri
     +         ,domain_origin_urj
     +         ,stagger_type
     +         ,map_proj_name,latlon_grid
     +         ,moad_known_lat, moad_known_lon, moad_known_loc
     +         ,moad_stand_lats, moad_stand_lons
     +         ,moad_delta_x, moad_delta_y
     +         ,silavwt_parm_wrf, toptwvl_parm_wrf
     +         ,num_staggers_wrf

      istatus = 0
      call s_len(generic_data_root,lenr)
      filename = generic_data_root(1:lenr)//'/static/wrfsi.nl'
      if(iflag_horzgrid_cmn.ne.1)then
         open(93,file=filename,status='old',err=900)
         rewind(93)
         read(93,hgridspec,err=901)
         close(93)
         iflag_horzgrid_cmn=1
      endif
      istatus = 1
      return

 900  print*,'error opening namelist file ', filename
      return

 901  print*,'error reading namelist file for hgridspec'
      write(*,hgridspec)
      return
      end

!-----------------------------
      subroutine read_wrfsi_vgridspec (istatus)

      implicit none
      include 'wrf_vgridspec.cmn'
      include 'grid_fname.cmn'

      namelist /vgridspec/
     + verticalcoord, moad_nz, vertical_increment
     +,vertical_stretch, max_vertical_inc, levels
     +,vstagger_type

      character*255 filename

      integer      istatus
      integer      iflag_vgridspec_cmn
      data         iflag_vgridspec_cmn/0/
      save         iflag_vgridspec_cmn

      integer      lenr

	write(6,*) 'execute read_wrfsi_vgridspec'

      istatus = 0
      call s_len(generic_data_root,lenr)
      filename = generic_data_root(1:lenr)//'/static/wrfsi.nl'
      if(iflag_vgridspec_cmn.ne.1)then
         open(93,file=filename,status='old',err=900)
         rewind(93)
         read(93,vgridspec,err=901)
         close(93)
         iflag_vgridspec_cmn=1
      endif
      istatus = 1
      return

 900  print*,'error opening namelist file ', filename
      return

 901  print*,'error reading namelist file for vgridspec'
      write(*,vgridspec)
      return
      end
!---------------------------------------------------------------
      subroutine read_wrfsi_sfcfiles (istatus)

      implicit none
      include 'wrf_sfcfiles.cmn'
      include 'grid_fname.cmn'

      namelist /sfcfiles/ topo_30s, topo_10m, pctland_10m
     &,landuse_30s, soiltype_top_30s, soiltype_bot_30s
     &,greenfrac, soiltemp_1deg, albedo_ncep, maxsnowalb
     &,islope, sstemp

      character*255 filename

      integer      istatus
      integer      iflag_sfcfiles_cmn
      data         iflag_sfcfiles_cmn/0/
      save         iflag_sfcfiles_cmn

      integer      lenr

      istatus = 0
      call s_len(generic_data_root,lenr)
      filename = generic_data_root(1:lenr)//'/static/wrfsi.nl'
      if(iflag_sfcfiles_cmn.ne.1)then
         open(93,file=filename,status='old',err=900)
         rewind(93)
         read(93,sfcfiles,err=901)
         close(93)
         iflag_sfcfiles_cmn=1
      endif
      istatus = 1
      return

 900  print*,'error opening namelist file ', filename
      return

 901  print*,'error reading namelist file for sfcfiles'
      write(*,sfcfiles)
      return
      end
!----------------------------
      subroutine read_wrfsi_rawdatapaths (istatus)

      implicit none
      include 'wrf_rawdatapaths.cmn'
      include 'grid_fname.cmn'

      character*255 filename

      integer      istatus
      integer      iflag_rawdatapaths_cmn
      data         iflag_rawdatapaths_cmn/0/
      save         iflag_rawdatapaths_cmn

      namelist /paths_to_raw_data/
     +          path_to_raw_pirep
     +         ,path_to_raw_rass, path_to_raw_profiler
     +         ,path_to_raw_blprass
     +         ,path_to_raw_blpprofiler,path_to_wsi_2d_radar
     +         ,path_to_wsi_3d_radar, path_to_qc_acars

      integer      lenr

      istatus = 0
      call s_len(generic_data_root,lenr)
      filename = generic_data_root(1:lenr)//'/static/wrfsi.nl'
      if(iflag_rawdatapaths_cmn.ne.1)then
         open(93,file=filename,status='old',err=900)
         rewind(93)
         read(93,paths_to_raw_data,err=901)
         close(93)
         iflag_rawdatapaths_cmn=1
      endif
      istatus = 1
      return

 900  print*,'error opening namelist file ', filename
      return

 901  print*,'error reading namelist file for paths_to_raw_data'
      write(*,paths_to_raw_data)
      return
      end
c--------------------------------
      subroutine get_stand_lon_wrf(std_lon,istatus)

      implicit  none

      include 'wrf_horzgrid.cmn'

      integer  istatus
      real     std_lon

      call read_wrfsi_hgridspec (istatus)
      if(istatus.ne.1)then
         print*,'error in get_stand_lon_wrf'
         return
      endif

      istatus = 1

      std_lon=moad_stand_lons(1)

      return
      end
!-----------------------------

      subroutine get_stand_lats_wrf(std_lat,std_lat2
     +                              ,istatus)

      implicit  none

      include 'wrf_horzgrid.cmn'
      integer  istatus

      real std_lat,std_lat2

      call read_wrfsi_hgridspec (istatus)
      if(istatus.ne.1)then
         print*,'error in get_stand_lon_wrf'
         return
      endif

      istatus = 1

      std_lat = moad_stand_lats(1)
      std_lat2= moad_stand_lats(2)

      return
      end
!-----------------------------

      subroutine get_c6_maproj_wrf(c6_maproj
     +                              ,istatus)

      implicit  none

      include 'wrf_horzgrid.cmn'
      character c6_maproj*6
      character wrftolaps_c6_maprojname*6
      integer  istatus

      call read_wrfsi_hgridspec (istatus)
      if(istatus.ne.1)then
         print*,'error in get_c6_maproj_wrf'
         return
      endif

      istatus = 1

      c6_maproj=wrftolaps_c6_maprojname(map_proj_name)

      return
      end
!-----------------------------

      subroutine get_grid_center_lon_wrf(grid_center_lon
     +                              ,istatus)

      implicit  none

      include 'wrf_horzgrid.cmn'
      include 'grid_fname.cmn'
      real     grid_center_lon
      integer  istatus

      call read_wrfsi_hgridspec (istatus)
      if(istatus.ne.1)then
         print*,'error in get_grid_center_lon_wrf'
         return
      endif

      istatus = 1

      grid_center_lon=moad_known_lon(1)

      return
      end

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

      subroutine get_grid_spacing_wrf(grid_spacing_m,istatus)
      implicit  none

      include 'wrf_horzgrid.cmn'
      real     grid_spacing_m
      integer  istatus

      call read_wrfsi_hgridspec (istatus)
      if(istatus.ne.1)then
         print*,'error in get_grid_spacing_wrf'
         return
      endif

      istatus = 1

      grid_spacing_m=moad_delta_x

      return
      end

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

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense