text:
c CHRUPK -- Unpack bytes into XCHAR (integer*2).  Should work on most byte
c addressable machines.  The input and output arrays may be the same.

	subroutine chrupk (a, aoff, b, boff, nchars)

	character*1 a(*)
	integer*2 b(*)
	integer	aoff, boff, nchars, i

 		do 10 i = 0, nchars-1
		    b(boff+i) = ichar (a(aoff+i))
 10		continue
	end

ext: f

max_stars_repo_name: ysBach/irafdocgen

max_issues_repo_name: kirxkirx/iraf

max_forks_repo_name: kirxkirx/iraf


text:
!     Floating point sizing

      program main

! This is not OK with gfortran and no implicit integer conversion is performed
      integer array(2.456)

      array(1) = 2
      print *, array(1)

      end


text:
module amr_f_mod

  use, intrinsic :: iso_c_binding
  use, intrinsic :: iso_fortran_env
  use :: flcl_mod

  implicit none

  public

  contains

    subroutine initialize_mesh_status( m, mesh_status )

      use, intrinsic :: iso_c_binding
      integer(c_int32_t), intent(in) :: m
      integer(c_int32_t), dimension(:), intent(inout), target, allocatable :: mesh_status

      integer :: ii

      allocate( mesh_status(m) )

      do ii = 1, m
        mesh_status(ii) = 1
      end do

    end subroutine initialize_mesh_status

    subroutine initialize_mesh_status_r64( m, mesh_status, view_ptr )

      use, intrinsic :: iso_c_binding
      use :: flcl_mod, only: kokkos_allocate_dualview
      integer(c_int32_t), intent(in) :: m
      real(c_double), dimension(:), intent(inout), pointer :: mesh_status
      type(c_ptr) :: view_ptr
      integer :: ii
      ! type(c_ptr) :: fptr

      ! character(len=255) ::fword1
      ! fword1 = C_CHAR_"foo"//C_NULL_CHAR

      ! fptr = c_loc(fword1)

      !allocate( mesh_status(m) )
      call kokkos_allocate_dualview(mesh_status, view_ptr, "foo", m)

      do ii = 1, m
        mesh_status(ii) = 1.0
      end do

    end subroutine initialize_mesh_status_r64

    subroutine list_mesh_status( mesh_status )

      use, intrinsic :: iso_c_binding
      integer(c_int32_t), dimension(:), intent(inout) :: mesh_status

      integer :: ii

      write(*,*)'list_mesh_status: ',mesh_status(:)

    end subroutine list_mesh_status

    ! subroutine refine_mesh_status( mesh_status, mesh_levels )

    !   use, intrinsic :: iso_c_binding
    !   implicit none
    !   integer(c_int32_t), dimension(:), intent(inout), target :: mesh_status
    !   integer(c_int32_t), dimension(:), intent(inout), target :: mesh_levels
    !   integer :: ii

    !   ! mark cells as refined by one level
    !   ! calculate length of new mesh_status
    !   ! allocate temporary new mesh_status
    !   ! deallocate old mesh_status
    !   ! re-allocate mesh_status
    !   ! copy new mesh_status into re-allocated mesh_status

    ! end subroutine refine_mesh_status

    function get_refine_count ( mesh_status, percentage ) result( refine_count )

      use, intrinsic :: iso_c_binding
      implicit none
      integer(c_int32_t),intent(in), dimension(:) :: mesh_status
      real(c_double) :: percentage
      integer(c_int32_t) :: refine_count

      integer(c_int32_t) :: length
      real(c_double) :: d_length
      real(c_double) :: d_refine_count

      length = size( mesh_status, 1, c_int32_t )
      d_length = real( length, c_double )
      d_refine_count = floor( d_length * percentage )
      refine_count = int( d_refine_count )

      ! write(*,*)'get_refine_count: amr vector refine count: ',refine_count

    end function get_refine_count

    function count_top_level( p_mesh_status ) result( ntop )
      use, intrinsic :: iso_c_binding
      implicit none
      integer(c_int32_t), intent(in), dimension(:) :: p_mesh_status
      integer(c_int32_t) :: ntop

      integer :: ii

      ntop = 0

      do ii = 1, size(p_mesh_status)
        if (p_mesh_status(ii) > 0) then
          ntop = ntop + 1
        end if
      end do

      write(*,*)'ntop: ',ntop
    end function count_top_level

    subroutine populate_ltop( p_mesh_status, p_ltop )
      use, intrinsic :: iso_c_binding
      implicit none
      integer(c_int32_t), intent(in), dimension(:) :: p_mesh_status
      integer(c_int32_t), intent(in), dimension(:), pointer :: p_ltop

      integer :: ii
      integer :: ntop

      ntop = 0

      do ii = 1, size(p_mesh_status)
        if (p_mesh_status(ii) > 0) then
          ntop = ntop + 1
          p_ltop(ntop) = ii
        end if
      end do

    end subroutine

    function count_chunks( p_mesh_status ) result( nchunks )
      use, intrinsic :: iso_c_binding
      implicit none
      integer(c_int32_t), intent(in), dimension(:) :: p_mesh_status
      integer(c_int32_t) :: nchunks

      integer :: ii

      nchunks = 1

      do ii = 2, size(p_mesh_status)
        if ( (p_mesh_status(ii-1) < 0 ) .and. (p_mesh_status(ii) > 0 ) ) then
          nchunks = nchunks + 1
        end if
      end do

      write(*,*)'nchunks: ',nchunks
    end function count_chunks

    subroutine  populate_chunks( p_mesh_status, chunk_start, chunk_end )
      use, intrinsic :: iso_c_binding
      implicit none
      integer(c_int32_t), intent(in), dimension(:) :: p_mesh_status
      integer(c_int32_t), intent(inout), dimension(:) :: chunk_start
      integer(c_int32_t), intent(inout), dimension(:) :: chunk_end
      integer(c_int32_t) :: nchunks

      integer :: ii

      nchunks = 1
      chunk_start(1) = 1

      do ii = 2, size(p_mesh_status)
        if ( (    p_mesh_status(ii-1) < 0 ) .and. (p_mesh_status(ii) > 0 ) ) then
          nchunks = nchunks + 1
          chunk_start(nchunks) = ii
        elseif ( (p_mesh_status(ii-1) > 0 ) .and. (p_mesh_status(ii) < 0 ) ) then
          chunk_end(nchunks) = ii-1
        elseif ( (p_mesh_status(ii-1) > 0 ) .and. (p_mesh_status(ii) > 0 ) ) then
          chunk_end(nchunks) = ii
        end if
      end do

      write(*,*)'nchunks: ',nchunks
    end subroutine populate_chunks

end module amr_f_mod

max_stars_repo_name: lanl/xkt

max_issues_repo_name: lanl/xkt

max_forks_repo_name: lanl/xkt


text:
program owo
print *,"*Notices Bulge*"
print *,"__        ___           _    _        _   _     _"
print *,"\ \      / / ^|__   __ _^| ^|_ ( ) ___  ^| ^|_^| ^|__ (_) ___"
print *," \ \ /\ / /^| '_ \ / _\`^| __^|// / __^| ^| __^| '_ \^| ^|/ __^|"
print *,"  \ V  V / ^| ^| ^| ^| (_^| ^| ^|_    \__ \ ^| ^|_^| ^| ^| ^| ^|\__ \"
print *,"   \_/\_/  ^|_^| ^|_^|\__,_^|\__^|   ^|___/ \___^|_^| ^|_^|_^|/___/"
end program owo

max_stars_repo_name: doczkal/OwO

max_issues_repo_name: doczkal/OwO

max_forks_repo_name: doczkal/OwO


MODULE solfrac_mod
  USE par_kind
  IMPLICIT NONE
  REAL(KIND = wp), PRIVATE, PARAMETER, DIMENSION(9) :: pp_wgt = (/0.2370, 0.36, 0.1790, 0.087, 0.08, 0.025, 0.025, 0.007, 0.0004/)
  REAL(KIND = wp), PRIVATE, PARAMETER, DIMENSION(9) :: pp_len = (/34.84, 2.266, 0.0315, 0.0055, 8.32E-4, 1.26E-4, 3.13E-4, 7.82E-4, 1.44E-5/)
  PUBLIC :: solfrac
  CONTAINS
  REAL(KIND = dp) FUNCTION solfrac(ptop, pbottom)
    REAL(KIND = wp), INTENT(IN) :: ptop, pbottom
    INTEGER :: jt
    !$ACC KERNELS
    solfrac = 0._wp
    DO jt = 1, 9
      solfrac = solfrac + pp_wgt(jt) * (EXP(- ptop / pp_len(jt)) - EXP(- pbottom / pp_len(jt)))
    END DO
    !$ACC END KERNELS
  END FUNCTION
END MODULE solfrac_mod