text:
function yggptr_c2f(x, realloc) result(flag)
  implicit none
  type(yggptr) :: x
  logical :: realloc
  integer(kind=c_size_t), pointer :: array_len
  integer(kind=c_size_t), pointer :: array_ndim
  integer(kind=c_size_t), dimension(:), pointer :: array_shape
  integer(kind=c_size_t), pointer :: precision
  integer(kind=8) :: i
  logical :: flag
  character(len=500) :: log_msg
  flag = .true.
  call ygglog_debug("yggptr_c2f: begin")
  allocate(array_len)
  allocate(array_ndim)
  allocate(array_shape(1))
  allocate(precision)
  array_len = 1
  array_ndim = 1
  array_shape(1) = 1
  precision = 1
  if (x%array) then
     if ((x%ndim.gt.1).or.x%ndarray) then
        deallocate(array_ndim)
        deallocate(array_shape)
        call c_f_pointer(x%ndim_ptr, array_ndim)
        call c_f_pointer(x%shape_ptr, array_shape, [array_ndim])
        do i = 1, array_ndim
           array_len = array_len * array_shape(i)
        end do
        write(log_msg, '("array_ndim = ",i7)') array_ndim
        call ygglog_debug(log_msg)
     else
        deallocate(array_len)
        call c_f_pointer(x%len_ptr, array_len)
        array_shape(1) = array_len
     end if
     write(log_msg, '("array_len = ",i7)') array_len
     call ygglog_debug(log_msg)
  end if
  if ((x%type.eq."character").or.(x%type.eq."unicode")) then
     deallocate(precision)
     call c_f_pointer(x%prec_ptr, precision)
     write(log_msg, '("precision = ",i7)') precision
     call ygglog_debug(log_msg)
  end if
  flag = yggptr_realloc(x, array_shape, precision, realloc)
  if (x%array) then
     if (x%alloc) then
        select type(item=>x%item)
        type is (unsigned1_1d)
           call yggptr_c2f_1darray_realloc_unsigned(x)
        type is (unsigned2_1d)
           call yggptr_c2f_1darray_realloc_unsigned(x)
        type is (unsigned4_1d)
           call yggptr_c2f_1darray_realloc_unsigned(x)
        type is (unsigned8_1d)
           call yggptr_c2f_1darray_realloc_unsigned(x)
        type is (c_long_1d)
           call yggptr_c2f_1darray_realloc_integer(x)
        type is (integer_1d)
           call yggptr_c2f_1darray_realloc_integer(x)
        type is (integer2_1d)
           call yggptr_c2f_1darray_realloc_integer(x)
        type is (integer4_1d)
           call yggptr_c2f_1darray_realloc_integer(x)
        type is (integer8_1d)
           call yggptr_c2f_1darray_realloc_integer(x)
        type is (real_1d)
           call yggptr_c2f_1darray_realloc_real(x)
        type is (real4_1d)
           call yggptr_c2f_1darray_realloc_real(x)
        type is (real8_1d)
           call yggptr_c2f_1darray_realloc_real(x)
        type is (real16_1d)
           call yggptr_c2f_1darray_realloc_real(x)
        type is (complex_1d)
           call yggptr_c2f_1darray_realloc_complex(x)
        type is (complex4_1d)
           call yggptr_c2f_1darray_realloc_complex(x)
        type is (complex8_1d)
           call yggptr_c2f_1darray_realloc_complex(x)
        type is (complex16_1d)
           call yggptr_c2f_1darray_realloc_complex(x)
        type is (logical_1d)
           call yggptr_c2f_1darray_realloc_logical(x)
        type is (logical1_1d)
           call yggptr_c2f_1darray_realloc_logical(x)
        type is (logical2_1d)
           call yggptr_c2f_1darray_realloc_logical(x)
        type is (logical4_1d)
           call yggptr_c2f_1darray_realloc_logical(x)
        type is (logical8_1d)
           call yggptr_c2f_1darray_realloc_logical(x)
        type is (character_1d)
           call yggptr_c2f_1darray_realloc_character(x)
        type is (unsigned1_nd)
           call yggptr_c2f_ndarray_realloc_unsigned(x)
        type is (unsigned2_nd)
           call yggptr_c2f_ndarray_realloc_unsigned(x)
        type is (unsigned4_nd)
           call yggptr_c2f_ndarray_realloc_unsigned(x)
        type is (unsigned8_nd)
           call yggptr_c2f_ndarray_realloc_unsigned(x)
        type is (c_long_nd)
           call yggptr_c2f_ndarray_realloc_integer(x)
        type is (integer_nd)
           call yggptr_c2f_ndarray_realloc_integer(x)
        type is (integer2_nd)
           call yggptr_c2f_ndarray_realloc_integer(x)
        type is (integer4_nd)
           call yggptr_c2f_ndarray_realloc_integer(x)
        type is (integer8_nd)
           call yggptr_c2f_ndarray_realloc_integer(x)
        type is (real_nd)
           call yggptr_c2f_ndarray_realloc_real(x)
        type is (real4_nd)
           call yggptr_c2f_ndarray_realloc_real(x)
        type is (real8_nd)
           call yggptr_c2f_ndarray_realloc_real(x)
        type is (real16_nd)
           call yggptr_c2f_ndarray_realloc_real(x)
        type is (complex_nd)
           call yggptr_c2f_ndarray_realloc_complex(x)
        type is (complex4_nd)
           call yggptr_c2f_ndarray_realloc_complex(x)
        type is (complex8_nd)
           call yggptr_c2f_ndarray_realloc_complex(x)
        type is (complex16_nd)
           call yggptr_c2f_ndarray_realloc_complex(x)
        type is (logical_nd)
           call yggptr_c2f_ndarray_realloc_logical(x)
        type is (logical1_nd)
           call yggptr_c2f_ndarray_realloc_logical(x)
        type is (logical2_nd)
           call yggptr_c2f_ndarray_realloc_logical(x)
        type is (logical4_nd)
           call yggptr_c2f_ndarray_realloc_logical(x)
        type is (logical8_nd)
           call yggptr_c2f_ndarray_realloc_logical(x)
        type is (character_nd)
           call yggptr_c2f_ndarray_realloc_character(x)
        class default
           write(log_msg, '("yggptr_c2f (realloc array transfer): Unexpected type: ",A)') x%type
           call ygglog_error(log_msg)
           stop "ERROR"
        end select
     else
        if (x%ndim.gt.1) then
           select type(item=>x%item_array)
           type is (ygguint1)
              call yggptr_c2f_ndarray_unsigned(x)
           type is (ygguint2)
              call yggptr_c2f_ndarray_unsigned(x)
           type is (ygguint4)
              call yggptr_c2f_ndarray_unsigned(x)
           type is (ygguint8)
              call yggptr_c2f_ndarray_unsigned(x)
           type is (integer(kind=2))
              call yggptr_c2f_ndarray_integer(x)
           type is (integer(kind=4))
              call yggptr_c2f_ndarray_integer(x)
           type is (integer(kind=8))
              call yggptr_c2f_ndarray_integer(x)
           type is (real(kind=4))
              call yggptr_c2f_ndarray_real(x)
           type is (real(kind=8))
              call yggptr_c2f_ndarray_real(x)
           ! type is (real(kind=16))
           !    call yggptr_c2f_ndarray_real(x)
           type is (complex(kind=4))
              call yggptr_c2f_ndarray_complex(x)
           type is (complex(kind=8))
              call yggptr_c2f_ndarray_complex(x)
           ! type is (complex(kind=16))
           !    call yggptr_c2f_ndarray_complex(x)
           type is (logical(kind=1))
              call yggptr_c2f_ndarray_logical(x)
           type is (logical(kind=2))
              call yggptr_c2f_ndarray_logical(x)
           type is (logical(kind=4))
              call yggptr_c2f_ndarray_logical(x)
           type is (logical(kind=8))
              call yggptr_c2f_ndarray_logical(x)
           type is (character(*))
              call yggptr_c2f_ndarray_character(x)
           class default
              write(log_msg, '("yggptr_c2f (",i2,"D array transfer): Unexpected type: ",A)') x%ndim, x%type
              call ygglog_error(log_msg)
              stop "ERROR"
           end select
        else
           select type(item=>x%item_array)
           type is (ygguint1)
           type is (ygguint2)
           type is (ygguint4)
           type is (ygguint8)
           type is (integer(kind=2))
           type is (integer(kind=4))
           type is (integer(kind=8))
           type is (real(kind=4))
           type is (real(kind=8))
           ! type is (real(kind=16))
           type is (complex(kind=4))
           type is (complex(kind=8))
           ! type is (complex(kind=16))
           type is (logical(kind=1))
           type is (logical(kind=2))
           type is (logical(kind=4))
           type is (logical(kind=8))
           type is (yggchar_r)
              call yggptr_c2f_array_character(x)
           type is (character(*))
              call yggptr_c2f_array_character(x)
           class default
              write(log_msg, '("yggptr_c2f (1d array transfer): Unexpected type: ",A)') x%type
              call ygglog_error(log_msg)
              stop "ERROR"
           end select
        end if
     end if
  else
     select type(item=>x%item)
     type is (ygguint1)
     type is (ygguint2)
     type is (ygguint4)
     type is (ygguint8)
     type is (integer(kind=2))
     type is (integer(kind=4))
     type is (integer(kind=8))
     type is (real(kind=4))
     type is (real(kind=8))
     ! type is (real(kind=16))
     type is (complex(kind=4))
     type is (complex(kind=8))
     ! type is (complex(kind=16))
     type is (logical(kind=1))
     type is (logical(kind=2))
     type is (logical(kind=4))
     type is (logical(kind=8))
     type is (yggnull)
     type is (yggchar_r)
        call yggptr_c2f_scalar_character(x)
     type is (character(*))
        call yggptr_c2f_scalar_character(x)
     class default
        if ((x%type.eq."ply").or.(x%type.eq."obj").or. &
             (x%type.eq."generic").or.(x%type.eq."object").or. &
             (x%type.eq."array").or.(x%type.eq."schema").or. &
             (x%type.eq."python").or.(x%type.eq."class").or. &
             (x%type.eq."instance").or.(x%type.eq."function")) then
           ! Use pointer
        else
           select type(item=>x%item)
           type is (character(kind=ucs4, len=*))
              call yggptr_c2f_scalar_character(x)
           class default
              write(log_msg, '("yggptr_c2f (scalar transfer): Unexpected type: ",A)') x%type
              call ygglog_error(log_msg)
              stop "ERROR"
           end select
        end if
     end select
  end if
  if (.not.x%array) then
     deallocate(array_len)
     deallocate(array_ndim)
     deallocate(array_shape)
  else
     if (x%ndim.gt.1) then
        deallocate(array_len)
        nullify(array_ndim)
        nullify(array_shape)
     else
        nullify(array_len)
        deallocate(array_ndim)
        deallocate(array_shape)
     end if
  end if
  if (.not.((x%type.eq."character").or.(x%type.eq."unicode"))) then
     deallocate(precision)
  else
     nullify(precision)
  end if
  call ygglog_debug("yggptr_c2f: end")
end function yggptr_c2f

subroutine yggptr_c2f_scalar_character(x)
  implicit none
  type(yggptr) :: x
  character(kind=ucs4, len=:), &
       pointer :: x_unicode
  character(len=:), pointer :: x_character
  type(yggchar_r), pointer :: x_character_realloc
  integer(kind=8) :: i
  select type(item=>x%item)
  type is (yggchar_r)
     x_character_realloc => item
     if (.not.associated(x_character_realloc%x)) then
        call c_f_pointer(x%ptr, x_character_realloc%x, [x%prec])
     end if
     do i = (x%prec + 1), size(x_character_realloc%x)
        x_character_realloc%x(i) = ' '
     end do
  type is (character(*))
     x_character => item
     do i = 1, x%prec
        x_character(i:i) = x%data_character_unit(i)
     end do
     do i = (x%prec + 1), len(x_character)
        x_character(i:i) = ' '
     end do
     deallocate(x%data_character_unit)
  class default
     select type(item=>x%item)
     type is (character(kind=ucs4, len=*))
        x_unicode => item
        do i = 1, (x%prec / 4)
           x_unicode(i:i) = x%data_unicode_unit(i)
        end do
        do i = ((x%prec / 4) + 1), len(x_unicode)
           x_unicode(i:i) = ' '
        end do
        deallocate(x%data_unicode_unit)
     class default
        call ygglog_error("yggptr_c2f_scalar_character: Unexpected type.")
        stop "ERROR"
     end select
  end select
end subroutine yggptr_c2f_scalar_character

subroutine yggptr_c2f_array_character(x)
  implicit none
  type(yggptr) :: x
  character, dimension(:), pointer :: xarr_character
  integer(kind=8) :: i, j
  select type(item=>x%item_array)
  type is (character(*))
     xarr_character => item
     do i = 1, x%len
        do j = 1, x%prec
           xarr_character(i)(j:j) = x%data_character_unit(i)
        end do
        do j = (x%prec + 1), len(xarr_character(i))
           xarr_character(i)(j:j) = ' '
        end do
     end do
     deallocate(x%data_character_unit)
  class default
     call ygglog_error("yggptr_c2f_array_character: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_array_character

! ND not reallocatable
subroutine yggptr_c2f_ndarray_unsigned(x)
  implicit none
  type(yggptr) :: x
  type(ygguint1), dimension(:), pointer :: x1
  type(ygguint2), dimension(:), pointer :: x2
  type(ygguint4), dimension(:), pointer :: x4
  type(ygguint8), dimension(:), pointer :: x8
  type(ygguint1), dimension(:, :), pointer :: x1_2d
  type(ygguint2), dimension(:, :), pointer :: x2_2d
  type(ygguint4), dimension(:, :), pointer :: x4_2d
  type(ygguint8), dimension(:, :), pointer :: x8_2d
  select type(item_2d=>x%item_array_2d)
  type is (ygguint1)
     x1_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (ygguint1)
        x1 => item_1d
        x1_2d = reshape(x1, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x1)
     class default
        call ygglog_error("yggptr_c2f_ndarray_unsigned: types do not match")
        stop "ERROR"
     end select
  type is (ygguint2)
     x2_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (ygguint2)
        x2 => item_1d
        x2_2d = reshape(x2, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x2)
     class default
        call ygglog_error("yggptr_c2f_ndarray_unsigned: types do not match")
        stop "ERROR"
     end select
  type is (ygguint4)
     x4_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (ygguint4)
        x4 => item_1d
        x4_2d = reshape(x4, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x4)
     class default
        call ygglog_error("yggptr_c2f_ndarray_unsigned: types do not match")
        stop "ERROR"
     end select
  type is (ygguint8)
     x8_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (ygguint8)
        x8 => item_1d
        x8_2d = reshape(x8, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x8)
     class default
        call ygglog_error("yggptr_c2f_ndarray_unsigned: types do not match")
        stop "ERROR"
     end select
  class default
     call ygglog_error("yggptr_c2f_ndarray_unsigned: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_unsigned
subroutine yggptr_c2f_ndarray_integer(x)
  implicit none
  type(yggptr) :: x
  integer(kind=2), dimension(:), pointer :: x2
  integer(kind=4), dimension(:), pointer :: x4
  integer(kind=8), dimension(:), pointer :: x8
  integer(kind=2), dimension(:, :), pointer :: x2_2d
  integer(kind=4), dimension(:, :), pointer :: x4_2d
  integer(kind=8), dimension(:, :), pointer :: x8_2d
  select type(item_2d=>x%item_array_2d)
  type is (integer(kind=2))
     x2_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (integer(kind=2))
        x2 => item_1d
        x2_2d = reshape(x2, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x2)
     class default
        call ygglog_error("yggptr_c2f_ndarray_integer: types do not match")
        stop "ERROR"
     end select
  type is (integer(kind=4))
     x4_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (integer(kind=4))
        x4 => item_1d
        x4_2d = reshape(x4, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x4)
     class default
        call ygglog_error("yggptr_c2f_ndarray_integer: types do not match")
        stop "ERROR"
     end select
  type is (integer(kind=8))
     x8_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (integer(kind=8))
        x8 => item_1d
        x8_2d = reshape(x8, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x8)
     class default
        call ygglog_error("yggptr_c2f_ndarray_integer: types do not match")
        stop "ERROR"
     end select
  class default
     call ygglog_error("yggptr_c2f_ndarray_integer: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_integer
subroutine yggptr_c2f_ndarray_real(x)
  implicit none
  type(yggptr) :: x
  real(kind=4), dimension(:), pointer :: x4
  real(kind=8), dimension(:), pointer :: x8
  ! real(kind=16), dimension(:), pointer :: x16
  real(kind=4), dimension(:, :), pointer :: x4_2d
  real(kind=8), dimension(:, :), pointer :: x8_2d
  ! real(kind=16), dimension(:, :), pointer :: x16_2d
  select type(item_2d=>x%item_array_2d)
  type is (real(kind=4))
     x4_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (real(kind=4))
        x4 => item_1d
        x4_2d = reshape(x4, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x4)
     class default
        call ygglog_error("yggptr_c2f_ndarray_real: types do not match")
        stop "ERROR"
     end select
  type is (real(kind=8))
     x8_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (real(kind=8))
        x8 => item_1d
        x8_2d = reshape(x8, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x8)
     class default
        call ygglog_error("yggptr_c2f_ndarray_real: types do not match")
        stop "ERROR"
     end select
  ! type is (real(kind=16))
  !    x16_2d => item_2d
  !    select type(item_1d=>x%item_array)
  !    type is (real(kind=16))
  !       x16 => item_1d
  !       x16_2d = reshape(x16, [x%shape(1), x%shape(2)])
  !       nullify(x%item_array)
  !       deallocate(x16)
  !    class default
  !       call ygglog_error("yggptr_c2f_ndarray_real: types do not match")
  !       stop "ERROR"
  !    end select
  class default
     call ygglog_error("yggptr_c2f_ndarray_real: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_real
subroutine yggptr_c2f_ndarray_complex(x)
  implicit none
  type(yggptr) :: x
  complex(kind=4), dimension(:), pointer :: x4
  complex(kind=8), dimension(:), pointer :: x8
  ! complex(kind=16), dimension(:), pointer :: x16
  complex(kind=4), dimension(:, :), pointer :: x4_2d
  complex(kind=8), dimension(:, :), pointer :: x8_2d
  ! complex(kind=16), dimension(:, :), pointer :: x16_2d
  select type(item_2d=>x%item_array_2d)
  type is (complex(kind=4))
     x4_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (complex(kind=4))
        x4 => item_1d
        x4_2d = reshape(x4, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x4)
     class default
        call ygglog_error("yggptr_c2f_ndarray_complex: types do not match")
        stop "ERROR"
     end select
  type is (complex(kind=8))
     x8_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (complex(kind=8))
        x8 => item_1d
        x8_2d = reshape(x8, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x8)
     class default
        call ygglog_error("yggptr_c2f_ndarray_complex: types do not match")
        stop "ERROR"
     end select
  ! type is (complex(kind=16))
  !    x16_2d => item_2d
  !    select type(item_1d=>x%item_array)
  !    type is (complex(kind=16))
  !       x16 => item_1d
  !       x16_2d = reshape(x16, [x%shape(1), x%shape(2)])
  !       nullify(x%item_array)
  !       deallocate(x16)
  !    class default
  !       call ygglog_error("yggptr_c2f_ndarray_complex: types do not match")
  !       stop "ERROR"
  !    end select
  class default
     call ygglog_error("yggptr_c2f_ndarray_complex: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_complex
subroutine yggptr_c2f_ndarray_logical(x)
  implicit none
  type(yggptr) :: x
  logical(kind=1), dimension(:), pointer :: x1
  logical(kind=2), dimension(:), pointer :: x2
  logical(kind=4), dimension(:), pointer :: x4
  logical(kind=8), dimension(:), pointer :: x8
  logical(kind=1), dimension(:, :), pointer :: x1_2d
  logical(kind=2), dimension(:, :), pointer :: x2_2d
  logical(kind=4), dimension(:, :), pointer :: x4_2d
  logical(kind=8), dimension(:, :), pointer :: x8_2d
  select type(item_2d=>x%item_array_2d)
  type is (logical(kind=1))
     x1_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (logical(kind=1))
        x1 => item_1d
        x1_2d = reshape(x1, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x1)
     class default
        call ygglog_error("yggptr_c2f_ndarray_logical: types do not match")
        stop "ERROR"
     end select
  type is (logical(kind=2))
     x2_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (logical(kind=2))
        x2 => item_1d
        x2_2d = reshape(x2, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x2)
     class default
        call ygglog_error("yggptr_c2f_ndarray_logical: types do not match")
        stop "ERROR"
     end select
  type is (logical(kind=4))
     x4_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (logical(kind=4))
        x4 => item_1d
        x4_2d = reshape(x4, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x4)
     class default
        call ygglog_error("yggptr_c2f_ndarray_logical: types do not match")
        stop "ERROR"
     end select
  type is (logical(kind=8))
     x8_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (logical(kind=8))
        x8 => item_1d
        x8_2d = reshape(x8, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(x8)
     class default
        call ygglog_error("yggptr_c2f_ndarray_logical: types do not match")
        stop "ERROR"
     end select
  class default
     call ygglog_error("yggptr_c2f_ndarray_logical: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_logical
subroutine yggptr_c2f_ndarray_character(x)
  implicit none
  type(yggptr) :: x
  character(len=:), dimension(:), pointer :: xc
  character(len=:), dimension(:, :), pointer :: xc_2d
  integer(kind=c_size_t) :: i, j
  select type(item_2d=>x%item_array_2d)
  type is (character(*))
     xc_2d => item_2d
     select type(item_1d=>x%item_array)
     type is (character(*))
        xc => item_1d
        allocate(character(len=x%prec) :: xc_2d(x%shape(1), x%shape(2)))
        do i = 1, x%shape(1)
           do j = 1, x%shape(2)
              xc_2d(i, j) = xc(i + (j-1)*(x%shape(1)))
           enddo
        enddo
        ! xc_2d = reshape(xc, [x%shape(1), x%shape(2)])
        nullify(x%item_array)
        deallocate(xc)
     class default
        call ygglog_error("yggptr_c2f_ndarray_logical: types do not match")
        stop "ERROR"
     end select
  class default
     call ygglog_error("yggptr_c2f_ndarray_character: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_character

! 1D reallocatable
subroutine yggptr_c2f_1darray_realloc_unsigned(x)
  implicit none
  type(yggptr) :: x
  type(unsigned1_1d), pointer :: x_unsigned1_1d
  type(unsigned2_1d), pointer :: x_unsigned2_1d
  type(unsigned4_1d), pointer :: x_unsigned4_1d
  type(unsigned8_1d), pointer :: x_unsigned8_1d
  select type(item=>x%item)
  type is (unsigned1_1d)
     x_unsigned1_1d => item
     if (.not.associated(x_unsigned1_1d%x)) then
        call c_f_pointer(x%ptr, x_unsigned1_1d%x, [x%len])
     end if
  type is (unsigned2_1d)
     x_unsigned2_1d => item
     if (.not.associated(x_unsigned2_1d%x)) then
        call c_f_pointer(x%ptr, x_unsigned2_1d%x, [x%len])
     end if
  type is (unsigned4_1d)
     x_unsigned4_1d => item
     if (.not.associated(x_unsigned4_1d%x)) then
        call c_f_pointer(x%ptr, x_unsigned4_1d%x, [x%len])
     end if
  type is (unsigned8_1d)
     x_unsigned8_1d => item
     if (.not.associated(x_unsigned8_1d%x)) then
        call c_f_pointer(x%ptr, x_unsigned8_1d%x, [x%len])
     end if
  class default
     call ygglog_error("yggptr_c2f_1darray_realloc_unsigned: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_1darray_realloc_unsigned
subroutine yggptr_c2f_1darray_realloc_integer(x)
  implicit none
  type(yggptr) :: x
  type(c_long_1d), pointer :: x_c_long_1d
  type(integer_1d), pointer :: x_integer_1d
  type(integer2_1d), pointer :: x_integer2_1d
  type(integer4_1d), pointer :: x_integer4_1d
  type(integer8_1d), pointer :: x_integer8_1d
  select type(item=>x%item)
  type is (c_long_1d)
     x_c_long_1d => item
     if (.not.associated(x_c_long_1d%x)) then
        call c_f_pointer(x%ptr, x_c_long_1d%x, [x%len])
     end if
  type is (integer_1d)
     x_integer_1d => item
     if (.not.associated(x_integer_1d%x)) then
        call c_f_pointer(x%ptr, x_integer_1d%x, [x%len])
     end if
  type is (integer2_1d)
     x_integer2_1d => item
     if (.not.associated(x_integer2_1d%x)) then
        call c_f_pointer(x%ptr, x_integer2_1d%x, [x%len])
     end if
  type is (integer4_1d)
     x_integer4_1d => item
     if (.not.associated(x_integer4_1d%x)) then
        call c_f_pointer(x%ptr, x_integer4_1d%x, [x%len])
     end if
  type is (integer8_1d)
     x_integer8_1d => item
     if (.not.associated(x_integer8_1d%x)) then
        call c_f_pointer(x%ptr, x_integer8_1d%x, [x%len])
     end if
  class default
     call ygglog_error("yggptr_c2f_1darray_realloc_integer: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_1darray_realloc_integer
subroutine yggptr_c2f_1darray_realloc_real(x)
  implicit none
  type(yggptr) :: x
  type(real_1d), pointer :: x_real_1d
  type(real4_1d), pointer :: x_real4_1d
  type(real8_1d), pointer :: x_real8_1d
  type(real16_1d), pointer :: x_real16_1d
  select type(item=>x%item)
  type is (real_1d)
     x_real_1d => item
     if (.not.associated(x_real_1d%x)) then
        call c_f_pointer(x%ptr, x_real_1d%x, [x%len])
     end if
  type is (real4_1d)
     x_real4_1d => item
     if (.not.associated(x_real4_1d%x)) then
        call c_f_pointer(x%ptr, x_real4_1d%x, [x%len])
     end if
  type is (real8_1d)
     x_real8_1d => item
     if (.not.associated(x_real8_1d%x)) then
        call c_f_pointer(x%ptr, x_real8_1d%x, [x%len])
     end if
  type is (real16_1d)
     x_real16_1d => item
     if (.not.associated(x_real16_1d%x)) then
        call c_f_pointer(x%ptr, x_real16_1d%x, [x%len])
     end if
  class default
     call ygglog_error("yggptr_c2f_1darray_realloc_real: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_1darray_realloc_real
subroutine yggptr_c2f_1darray_realloc_complex(x)
  implicit none
  type(yggptr) :: x
  type(complex_1d), pointer :: x_complex_1d
  type(complex4_1d), pointer :: x_complex4_1d
  type(complex8_1d), pointer :: x_complex8_1d
  type(complex16_1d), pointer :: x_complex16_1d
  select type(item=>x%item)
  type is (complex_1d)
     x_complex_1d => item
     if (.not.associated(x_complex_1d%x)) then
        call c_f_pointer(x%ptr, x_complex_1d%x, [x%len])
     end if
  type is (complex4_1d)
     x_complex4_1d => item
     if (.not.associated(x_complex4_1d%x)) then
        call c_f_pointer(x%ptr, x_complex4_1d%x, [x%len])
     end if
  type is (complex8_1d)
     x_complex8_1d => item
     if (.not.associated(x_complex8_1d%x)) then
        call c_f_pointer(x%ptr, x_complex8_1d%x, [x%len])
     end if
  type is (complex16_1d)
     x_complex16_1d => item
     if (.not.associated(x_complex16_1d%x)) then
        call c_f_pointer(x%ptr, x_complex16_1d%x, [x%len])
     end if
  class default
     call ygglog_error("yggptr_c2f_1darray_realloc_complex: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_1darray_realloc_complex
subroutine yggptr_c2f_1darray_realloc_logical(x)
  implicit none
  type(yggptr) :: x
  type(logical_1d), pointer :: x_logical_1d
  type(logical1_1d), pointer :: x_logical1_1d
  type(logical2_1d), pointer :: x_logical2_1d
  type(logical4_1d), pointer :: x_logical4_1d
  type(logical8_1d), pointer :: x_logical8_1d
  select type(item=>x%item)
  type is (logical_1d)
     x_logical_1d => item
     if (.not.associated(x_logical_1d%x)) then
        call c_f_pointer(x%ptr, x_logical_1d%x, [x%len])
     end if
  type is (logical1_1d)
     x_logical1_1d => item
     if (.not.associated(x_logical1_1d%x)) then
        call c_f_pointer(x%ptr, x_logical1_1d%x, [x%len])
     end if
  type is (logical2_1d)
     x_logical2_1d => item
     if (.not.associated(x_logical2_1d%x)) then
        call c_f_pointer(x%ptr, x_logical2_1d%x, [x%len])
     end if
  type is (logical4_1d)
     x_logical4_1d => item
     if (.not.associated(x_logical4_1d%x)) then
        call c_f_pointer(x%ptr, x_logical4_1d%x, [x%len])
     end if
  type is (logical8_1d)
     x_logical8_1d => item
     if (.not.associated(x_logical8_1d%x)) then
        call c_f_pointer(x%ptr, x_logical8_1d%x, [x%len])
     end if
  class default
     call ygglog_error("yggptr_c2f_1darray_realloc_logical: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_1darray_realloc_logical
subroutine yggptr_c2f_1darray_realloc_character(x)
  implicit none
  type(yggptr) :: x
  integer(kind=8) :: i
  type(character_1d), pointer :: x_character_1d
  select type(item=>x%item)
  type is (character_1d)
     x_character_1d => item
     if (.not.associated(x%data_character_unit)) then
        call c_f_pointer(x%ptr, x%data_character_unit, [x%prec*x%len])
     end if
     do i = 1, x%len
        x_character_1d%x(i)%x = x%data_character_unit( &
             (1+(i-1)*x%prec):(i*x%prec))
     end do
     deallocate(x%data_character_unit)
  class default
     call ygglog_error("yggptr_c2f_1darray_realloc_character: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_1darray_realloc_character

! ND reallocatable
subroutine yggptr_c2f_ndarray_realloc_unsigned(x)
  implicit none
  type(yggptr) :: x
  type(unsigned1_nd), pointer :: x_unsigned1_nd
  type(unsigned2_nd), pointer :: x_unsigned2_nd
  type(unsigned4_nd), pointer :: x_unsigned4_nd
  type(unsigned8_nd), pointer :: x_unsigned8_nd
  select type(item=>x%item)
  type is (unsigned1_nd)
     x_unsigned1_nd => item
     if (.not.associated(x_unsigned1_nd%x)) then
        call c_f_pointer(x%ptr, x_unsigned1_nd%x, [x%len])
     end if
     if (.not.associated(x_unsigned1_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_unsigned1_nd%shape, [x%ndim])
     end if
  type is (unsigned2_nd)
     x_unsigned2_nd => item
     if (.not.associated(x_unsigned2_nd%x)) then
        call c_f_pointer(x%ptr, x_unsigned2_nd%x, [x%len])
     end if
     if (.not.associated(x_unsigned2_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_unsigned2_nd%shape, [x%ndim])
     end if
  type is (unsigned4_nd)
     x_unsigned4_nd => item
     if (.not.associated(x_unsigned4_nd%x)) then
        call c_f_pointer(x%ptr, x_unsigned4_nd%x, [x%len])
     end if
     if (.not.associated(x_unsigned4_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_unsigned4_nd%shape, [x%ndim])
     end if
  type is (unsigned8_nd)
     x_unsigned8_nd => item
     if (.not.associated(x_unsigned8_nd%x)) then
        call c_f_pointer(x%ptr, x_unsigned8_nd%x, [x%len])
     end if
     if (.not.associated(x_unsigned8_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_unsigned8_nd%shape, [x%ndim])
     end if
  class default
     call ygglog_error("yggptr_c2f_ndarray_realloc_unsigned: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_realloc_unsigned
subroutine yggptr_c2f_ndarray_realloc_integer(x)
  implicit none
  type(yggptr) :: x
  type(c_long_nd), pointer :: x_c_long_nd
  type(integer_nd), pointer :: x_integer_nd
  type(integer2_nd), pointer :: x_integer2_nd
  type(integer4_nd), pointer :: x_integer4_nd
  type(integer8_nd), pointer :: x_integer8_nd
  select type(item=>x%item)
  type is (c_long_nd)
     x_c_long_nd => item
     if (.not.associated(x_c_long_nd%x)) then
        call c_f_pointer(x%ptr, x_c_long_nd%x, [x%len])
     end if
     if (.not.associated(x_c_long_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_c_long_nd%shape, [x%ndim])
     end if
  type is (integer_nd)
     x_integer_nd => item
     if (.not.associated(x_integer_nd%x)) then
        call c_f_pointer(x%ptr, x_integer_nd%x, [x%len])
     end if
     if (.not.associated(x_integer_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_integer_nd%shape, [x%ndim])
     end if
  type is (integer2_nd)
     x_integer2_nd => item
     if (.not.associated(x_integer2_nd%x)) then
        call c_f_pointer(x%ptr, x_integer2_nd%x, [x%len])
     end if
     if (.not.associated(x_integer2_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_integer2_nd%shape, [x%ndim])
     end if
  type is (integer4_nd)
     x_integer4_nd => item
     if (.not.associated(x_integer4_nd%x)) then
        call c_f_pointer(x%ptr, x_integer4_nd%x, [x%len])
     end if
     if (.not.associated(x_integer4_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_integer4_nd%shape, [x%ndim])
     end if
  type is (integer8_nd)
     x_integer8_nd => item
     if (.not.associated(x_integer8_nd%x)) then
        call c_f_pointer(x%ptr, x_integer8_nd%x, [x%len])
     end if
     if (.not.associated(x_integer8_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_integer8_nd%shape, [x%ndim])
     end if
  class default
     call ygglog_error("yggptr_c2f_ndarray_realloc_integer: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_realloc_integer
subroutine yggptr_c2f_ndarray_realloc_real(x)
  implicit none
  type(yggptr) :: x
  type(real_nd), pointer :: x_real_nd
  type(real4_nd), pointer :: x_real4_nd
  type(real8_nd), pointer :: x_real8_nd
  type(real16_nd), pointer :: x_real16_nd
  select type(item=>x%item)
  type is (real_nd)
     x_real_nd => item
     if (.not.associated(x_real_nd%x)) then
        call c_f_pointer(x%ptr, x_real_nd%x, [x%len])
     end if
     if (.not.associated(x_real_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_real_nd%shape, [x%ndim])
     end if
  type is (real4_nd)
     x_real4_nd => item
     if (.not.associated(x_real4_nd%x)) then
        call c_f_pointer(x%ptr, x_real4_nd%x, [x%len])
     end if
     if (.not.associated(x_real4_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_real4_nd%shape, [x%ndim])
     end if
  type is (real8_nd)
     x_real8_nd => item
     if (.not.associated(x_real8_nd%x)) then
        call c_f_pointer(x%ptr, x_real8_nd%x, [x%len])
     end if
     if (.not.associated(x_real8_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_real8_nd%shape, [x%ndim])
     end if
  type is (real16_nd)
     x_real16_nd => item
     if (.not.associated(x_real16_nd%x)) then
        call c_f_pointer(x%ptr, x_real16_nd%x, [x%len])
     end if
     if (.not.associated(x_real16_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_real16_nd%shape, [x%ndim])
     end if
  class default
     call ygglog_error("yggptr_c2f_ndarray_realloc_real: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_realloc_real
subroutine yggptr_c2f_ndarray_realloc_complex(x)
  implicit none
  type(yggptr) :: x
  type(complex_nd), pointer :: x_complex_nd
  type(complex4_nd), pointer :: x_complex4_nd
  type(complex8_nd), pointer :: x_complex8_nd
  type(complex16_nd), pointer :: x_complex16_nd
  select type(item=>x%item)
  type is (complex_nd)
     x_complex_nd => item
     if (.not.associated(x_complex_nd%x)) then
        call c_f_pointer(x%ptr, x_complex_nd%x, [x%len])
     end if
     if (.not.associated(x_complex_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_complex_nd%shape, [x%ndim])
     end if
  type is (complex4_nd)
     x_complex4_nd => item
     if (.not.associated(x_complex4_nd%x)) then
        call c_f_pointer(x%ptr, x_complex4_nd%x, [x%len])
     end if
     if (.not.associated(x_complex4_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_complex4_nd%shape, [x%ndim])
     end if
  type is (complex8_nd)
     x_complex8_nd => item
     if (.not.associated(x_complex8_nd%x)) then
        call c_f_pointer(x%ptr, x_complex8_nd%x, [x%len])
     end if
     if (.not.associated(x_complex8_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_complex8_nd%shape, [x%ndim])
     end if
  type is (complex16_nd)
     x_complex16_nd => item
     if (.not.associated(x_complex16_nd%x)) then
        call c_f_pointer(x%ptr, x_complex16_nd%x, [x%len])
     end if
     if (.not.associated(x_complex16_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_complex16_nd%shape, [x%ndim])
     end if
  class default
     call ygglog_error("yggptr_c2f_ndarray_realloc_complex: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_realloc_complex
subroutine yggptr_c2f_ndarray_realloc_logical(x)
  implicit none
  type(yggptr) :: x
  type(logical_nd), pointer :: x_logical_nd
  type(logical1_nd), pointer :: x_logical1_nd
  type(logical2_nd), pointer :: x_logical2_nd
  type(logical4_nd), pointer :: x_logical4_nd
  type(logical8_nd), pointer :: x_logical8_nd
  select type(item=>x%item)
  type is (logical_nd)
     x_logical_nd => item
     if (.not.associated(x_logical_nd%x)) then
        call c_f_pointer(x%ptr, x_logical_nd%x, [x%len])
     end if
     if (.not.associated(x_logical_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_logical_nd%shape, [x%ndim])
     end if
  type is (logical1_nd)
     x_logical1_nd => item
     if (.not.associated(x_logical1_nd%x)) then
        call c_f_pointer(x%ptr, x_logical1_nd%x, [x%len])
     end if
     if (.not.associated(x_logical1_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_logical1_nd%shape, [x%ndim])
     end if
  type is (logical2_nd)
     x_logical2_nd => item
     if (.not.associated(x_logical2_nd%x)) then
        call c_f_pointer(x%ptr, x_logical2_nd%x, [x%len])
     end if
     if (.not.associated(x_logical2_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_logical2_nd%shape, [x%ndim])
     end if
  type is (logical4_nd)
     x_logical4_nd => item
     if (.not.associated(x_logical4_nd%x)) then
        call c_f_pointer(x%ptr, x_logical4_nd%x, [x%len])
     end if
     if (.not.associated(x_logical4_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_logical4_nd%shape, [x%ndim])
     end if
  type is (logical8_nd)
     x_logical8_nd => item
     if (.not.associated(x_logical8_nd%x)) then
        call c_f_pointer(x%ptr, x_logical8_nd%x, [x%len])
     end if
     if (.not.associated(x_logical8_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_logical8_nd%shape, [x%ndim])
     end if
  class default
     call ygglog_error("yggptr_c2f_ndarray_realloc_logical: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_realloc_logical
subroutine yggptr_c2f_ndarray_realloc_character(x)
  implicit none
  type(yggptr) :: x
  integer(kind=8) :: i
  type(character_nd), pointer :: x_character_nd
  select type(item=>x%item)
  type is (character_nd)
     x_character_nd => item
     if (.not.associated(x%data_character_unit)) then
        call c_f_pointer(x%ptr, x%data_character_unit, [x%prec*x%len])
     end if
     do i = 1, x%len
        x_character_nd%x(i)%x = x%data_character_unit( &
             (1+(i-1)*x%prec):(i*x%prec))
     end do
     deallocate(x%data_character_unit)
     if (.not.associated(x_character_nd%shape)) then
        call c_f_pointer(x%shape_ptr, x_character_nd%shape, [x%ndim])
     end if
  class default
     call ygglog_error("yggptr_c2f_ndarray_realloc_character: Unexpected type.")
     stop "ERROR"
  end select
end subroutine yggptr_c2f_ndarray_realloc_character

max_stars_repo_name: Xyzic/yggdrasil

max_issues_repo_name: Xyzic/yggdrasil

max_forks_repo_name: Xyzic/yggdrasil


text:
! { dg-do compile }
! Check for conflicts
! PR fortran/29657

function f1() ! { dg-error "PROCEDURE attribute conflicts with SAVE attribute" }
  implicit none
  real, save :: f1
  f1 = 1.0
end function f1

function f2() ! { dg-error "PROCEDURE attribute conflicts with SAVE attribute" }
  implicit none
  real :: f2
  save f2
  f2 = 1.0
end function f2

subroutine f3()
  implicit none
  dimension f3(3) ! { dg-error "SUBROUTINE attribute conflicts with DIMENSION attribute" }
end subroutine f3

subroutine f4(b)
  implicit none
  real :: b
  entry b ! { dg-error "DUMMY attribute conflicts with ENTRY attribute" }
end subroutine f4

function f5(a)
  implicit none
  real :: a,f5
  entry a ! { dg-error "DUMMY attribute conflicts with ENTRY attribute" }
  f5 = 3.4
end function f5

subroutine f6(cos)
  implicit none
  real :: cos
  intrinsic cos ! { dg-error "DUMMY attribute conflicts with INTRINSIC attribute" }
end subroutine f6

subroutine f7(sin)
  implicit none
  real :: sin
  external sin
end subroutine f7

program test
  implicit none
  dimension test(3) ! { dg-error "PROGRAM attribute conflicts with DIMENSION attribute" }
end program test

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
module photonMod

    use constants, only : wp
    use vector_class

    implicit none

    type :: photon

        type(vector)  :: pos                     ! position
        real(kind=wp) :: nxp, nyp, nzp                ! direction vectors
        real(kind=wp) :: sint, cost, sinp, cosp, phi  ! direction cosines
        real(kind=wp) :: wavelength                   ! Only used if tracking the phase
        integer       :: xcell, ycell, zcell          ! grid cell position
        logical       :: tflag                        ! Is photon dead?
        integer       :: layer                        ! id of sdf the packet is inside
        integer       :: id                           ! thread running packet
        integer       :: cnts                         !  number of sdf evals.

        procedure(generic_emit), pointer :: emit => null()

    end type photon

    interface photon
        module procedure init_source
    end interface photon

    abstract interface
        subroutine generic_emit(this, dict)

            use fhash, only : fhash_tbl_t

            import :: photon
            class(photon) :: this
            type(fhash_tbl_t), optional, intent(IN) :: dict

        end subroutine generic_emit
    end interface

    private
    public :: photon, init_source

    contains

        type(photon) function init_source(choice)

            implicit none

            character(*), intent(IN) :: choice

            if(choice == "uniform")then
                init_source%emit => uniform
            elseif(choice == "pencil")then
                init_source%emit => pencil
            ! elseif(choice == "annulus")then
            !     init_source%emit => annulus
            elseif(choice == "focus")then
                init_source%emit => focus
            elseif(choice == "point")then
                init_source%emit => point
            ! else
            !     init_source%emit => circular_beam
            end if

        end function init_source

        subroutine point(this, dict)
        !isotropic point source

            use sim_state_mod, only : state
            use random,        only : ran2
            use constants,     only : twoPI
            use fhash,         only : fhash_tbl_t, key=>fhash_key

            implicit none

            class(photon) :: this
            type(fhash_tbl_t), optional, intent(IN) :: dict
            integer :: cell(3)

            call dict%get(key("pos%x"), this%pos%x)
            call dict%get(key("pos%y"), this%pos%y)
            call dict%get(key("pos%z"), this%pos%z)

            this%phi  = ran2()*twoPI
            this%cosp = cos(this%phi)
            this%sinp = sin(this%phi)
            this%cost = 2._wp*ran2()-1._wp
            this%sint = sqrt(1._wp - this%cost**2)

            this%nxp = this%sint * this%cosp
            this%nyp = this%sint * this%sinp
            this%nzp = this%cost

            this%tflag = .false.
            this%cnts = 0
            this%layer=1

            ! Linear Grid
            cell = state%grid%get_voxel(this%pos)
            this%xcell = cell(1)
            this%ycell = cell(2)
            this%zcell = cell(3)

        end subroutine point

        subroutine focus(this, dict)

            use random,        only : ranu
            use sim_state_mod, only : state
            use utils,         only : deg2rad
            use vector_class,  only : length
            use fhash,         only : fhash_tbl_t

            implicit none

            class(photon) :: this
            type(fhash_tbl_t), optional, intent(IN) :: dict

            type(vector)  :: targ, dir
            real(kind=wp) :: dist
            integer       :: cell(3)

            targ = vector(0._wp,0._wp,0._wp)

            this%pos%x = ranu(-state%grid%xmax, state%grid%xmax)
            this%pos%y = ranu(-state%grid%ymax, state%grid%ymax)
            this%pos%z = state%grid%zmax - 1e-8_wp

            dist = length(this%pos)

            dir = (-1._wp)*this%pos / dist
            dir = dir%magnitude()

            this%nxp = dir%x
            this%nyp = dir%y
            this%nzp = dir%z
            this%phi  = atan2(this%nyp, this%nxp)
            this%cosp = cos(this%phi)
            this%sinp = sin(this%phi)
            this%cost = this%nzp
            this%sint = sqrt(1._wp - this%cost**2)

            this%nxp = this%sint * this%cosp
            this%nyp = this%sint * this%sinp
            this%nzp = this%cost

            this%tflag = .false.

            ! Linear Grid
            cell = state%grid%get_voxel(this%pos)
            this%xcell = cell(1)
            this%ycell = cell(2)
            this%zcell = cell(3)

        end subroutine focus

        subroutine uniform(this, dict)
        !uniformly illuminate a surface of the simulation media
        !TODO change to user defined patch inplace of whole side
            use random,        only : ranu, ran2, randint
            use sim_state_mod, only : state
            use fhash,         only : fhash_tbl_t, key=>fhash_key

            implicit none

            class(photon) :: this
            type(fhash_tbl_t), optional, intent(IN) :: dict

            integer :: cell(3)
            character(len=:),allocatable :: dir

            call dict%get(key("dir"), dir)
            select case(dir)
            case("-z")
                this%pos%x = ranu(-state%grid%xmax, state%grid%xmax)
                this%pos%y = ranu(-state%grid%ymax, state%grid%ymax)
                this%pos%z = state%grid%zmax-1e-8_wp

                this%phi  = 0._wp
                this%cosp = 1._wp
                this%sinp = 0._wp
                this%cost = -1._wp
                this%sint = 0._wp
            case("+z")
                this%pos%x = ranu(-state%grid%xmax, state%grid%xmax)
                this%pos%y = ranu(-state%grid%ymax, state%grid%ymax)
                this%pos%z = -state%grid%zmax + 1e-8_wp

                this%phi  = 0._wp
                this%cosp = 1._wp
                this%sinp = 0._wp
                this%cost = 1._wp
                this%sint = 0._wp

            case("-x")
                this%pos%x = state%grid%xmax-1e-8_wp
                this%pos%y = ranu(-state%grid%ymax, state%grid%ymax)
                this%pos%z = ranu(-state%grid%zmax, state%grid%zmax)

                this%phi  = 0._wp
                this%cosp = 1._wp
                this%sinp = 0._wp
                this%cost = 0._wp
                this%sint = -1._wp
            case("+x")
                this%pos%x = -state%grid%xmax+1e-8_wp
                this%pos%y = ranu(-state%grid%ymax, state%grid%ymax)
                this%pos%z = ranu(-state%grid%zmax, state%grid%zmax)

                this%phi  = 0._wp
                this%cosp = 1._wp
                this%sinp = 0._wp
                this%cost = 0._wp
                this%sint = 1._wp
            case("-y")
                this%pos%x = ranu(-state%grid%xmax, state%grid%xmax)
                this%pos%y = state%grid%xmax-1e-8_wp
                this%pos%z = ranu(-state%grid%zmax, state%grid%zmax)

                this%phi  = 0._wp
                this%cosp = 0._wp
                this%sinp = -1._wp
                this%cost = 0._wp
                this%sint = 1._wp
            case("+y")
                this%pos%x = ranu(-state%grid%xmax, state%grid%xmax)
                this%pos%y = -state%grid%xmax+1e-8_wp
                this%pos%z = ranu(-state%grid%zmax, state%grid%zmax)

                this%phi  = 0._wp
                this%cosp = 0._wp
                this%sinp = 1._wp
                this%cost = 0._wp
                this%sint = 1._wp
            case default
                error stop "No such direction for uniform source"
            end select

            this%nxp = this%sint * this%cosp
            this%nyp = this%sint * this%sinp
            this%nzp = this%cost

            this%tflag = .false.
            this%cnts = 0

            ! Linear Grid
            cell = state%grid%get_voxel(this%pos)
            this%xcell = cell(1)
            this%ycell = cell(2)
            this%zcell = cell(3)

        end subroutine uniform

        subroutine pencil(this, dict)

            use random,        only : ranu
            use sim_state_mod, only : state
            use fhash,         only : fhash_tbl_t

            implicit none

            class(photon) :: this
            type(fhash_tbl_t), optional, intent(IN) :: dict

            integer :: cell(3)

            this%pos%z = state%grid%zmax - epsilon(1._wp)
            this%pos%x = ranu(-state%grid%xmax/10._wp, state%grid%xmax/10._wp)
            this%pos%y = ranu(-state%grid%ymax/10._wp, state%grid%ymax/10._wp)

            this%phi = 0._wp
            this%cosp = 0._wp
            this%sinp = 0._wp
            this%cost = -1._wp
            this%sint =  0._wp

            this%nxp = this%sint * this%cosp
            this%nyp = this%sint * this%sinp
            this%nzp = this%cost

            this%tflag = .false.

            ! Linear Grid
            cell = state%grid%get_voxel(this%pos)
            this%xcell = cell(1)
            this%ycell = cell(2)
            this%zcell = cell(3)

        end subroutine pencil

        ! subroutine annulus(this, dict)

        !     use gridMod
        !     use utils,     only : deg2rad
        !     use random,    only : ranu, ran2, rang
        !     use surfaces,  only : reflect_refract

        !     implicit none

        !     class(photon) :: this
        !     type(dict_t), optional, intent(IN) :: dict

        !     real :: ra, ta, alpha, Ls, beam_width, rp, da, dist
        !     real :: tana, x, y, total_length, axicon_n, height, k
        !     type(vector) :: pos, dir, normal, centre, newpos
        !     logical :: flag

        !     ra = 4. ! 12.7mm
        !     beam_width = .5d0 !100um
        !     do
        !         call rang(x, y, 0., beam_width)
        !         rp = sqrt(x**2 + y**2)
        !         axicon_n = 1.45
        !         ta = 0.0d-3  ! 0.0 mm
        !         alpha = deg2rad(20.0)
        !         tana = tan(alpha)
        !         height = tana * ra
        !         Ls = 10.  ! 100mm
        !         centre = vector(0., 0., 0.)
        !         k  = (rp / height)**2

        !         da = (ra - rp) * tana
        !         pos = vector(x, y, -da)

        !         total_length = Ls + height

        !         dir = vector(0., 0., -1.)
        !         !https://math.stackexchange.com/a/3349448
        !         normal =vector(2.*pos%x, 2.*pos%y, -2*ra**2*(pos%z+height)/height**2)
        !         normal = normal%magnitude()
        !         call reflect_refract(dir, normal, axicon_n, 1., flag)
        !         if(.not. flag)then
        !             exit
        !         end if
        !     end do

        !     !move packet to L1 location
        !     pos = pos + dir * (-total_length / dir%z)

        !     !focus to a point
        !     pos%z = 4.e0 !f distance 40mm
        !     call rang(x, y, 0., 5.d-4)

        !     newpos = vector(x, y, dict%get_value_real("focus"))!.775
        !     dist = sqrt((pos%x - newpos%x)**2 + (pos%y - newpos%y)**2 +(pos%z - newpos%z)**2)

        !     dir = (-1.)*pos / dist
        !     dist = (grid%zmax + 5e-8 - pos%z) / dir%z
        !     pos = pos + dist * dir
        !     this%pos = pos

        !     dir = dir%magnitude()

        !     this%nxp = dir%x
        !     this%nyp = dir%y
        !     this%nzp = dir%z

        !     this%cost = this%nzp
        !     this%sint = sqrt(1.e0 - this%cost**2)

        !     this%phi = atan2(this%nyp, this%nxp)
        !     this%cosp = cos(this%phi)
        !     this%sinp = sin(this%phi)

        !     this%tflag = .false.
        !     this%layer = 3
        !     this%cnts = 0

        !     !teleport to just inside medium
        !     this%pos%z = grid%zmax - 1e-8

        !     ! Linear Grid
        !     this%xcell=int(grid%nxg*(this%pos%x+grid%xmax)/(2.*grid%xmax))+1
        !     this%ycell=int(grid%nyg*(this%pos%y+grid%ymax)/(2.*grid%ymax))+1
        !     this%zcell=int(grid%nzg*(this%pos%z+grid%zmax)/(2.*grid%zmax))+1

        ! end subroutine annulus

        ! subroutine circular_beam(this dict)

        !     use random,    only : ranu, rang
        !     use surfaces,  only : intersect_cone, reflect_refract
        !     use vector_class

        !     implicit none

        !     class(photon) :: this
        !     type(dict_t), optional,  intent(IN) :: dict

        !     real :: seperation, beam_width, radius, height, alpha, axicon_n, base_pos
        !     real :: posx, posy, t, k
        !     type(vector) :: centre, pos, dir, normal
        !     logical :: flag

        !     seperation = 2.5d-3
        !     !beam paramaters
        !     beam_width = 100d-6
        !     !axicon paramaters
        !     radius = 12.7d-3
        !     height = 1.1d-3
        !     alpha = atan(height / radius)
        !     k  = (radius / height)**2
        !     axicon_n = 1.45
        !     base_pos = grid%zmax + ((seperation + beam_width) / tan(alpha * (axicon_n -1.)))
        !     centre = vector(0., 0., base_pos)

        !     call rang(posx, posy, 0., beam_width)
        !     pos = centre + vector(posx, posy, 2*height+base_pos)!2*height as want the upper cone
        !     dir = vector(0., 0., -1.)
        !     ! cartesian equation defines these two cones. usually want the lower cone
        !     ! in this case we want the upper cone as the axicon points down
        !     ! therefore need to change the computation of the normals and initial postion of packet
        !     !
        !     ! \      /
        !     !  \    /   upper cone
        !     !   \  /
        !     !    \/
        !     !    /\
        !     !   /  \
        !     !  /    \   lower cone
        !     ! /      \

        !     flag = intersect_cone(pos, dir, t, centre, radius, height)
        !     if(flag)then
        !         pos = pos + t*dir
        !         if(pos%z >= centre%z+height)then! >= for upper cone
        !             !derivative of the cartesian cone eqn
        !             normal = vector(2*(pos%x-centre%x) / k, 2*(pos%y-centre%y) / k, -2*(pos%z-centre%z)+2*height)
        !             normal = normal *(-1.)! upper cone so invert normals
        !             normal = normal%magnitude()
        !             call reflect_refract(dir, normal, axicon_n, 1., flag)
        !             ! move to mediums surface and step inside
        !             t = ((grid%zmax- epsilon(1.e0)) - pos%z) / dir%z
        !             pos = pos + t*dir
        !         end if
        !     end if

        !     this%pos = pos

        !     this%nxp = dir%x
        !     this%nyp = dir%y
        !     this%nzp = dir%z

        !     this%cost = this%nzp
        !     this%sint = sqrt(1.e0 - this%cost**2)

        !     this%phi = atan2(this%nyp, this%nxp)
        !     this%cosp = cos(this%phi)
        !     this%sinp = sin(this%phi)

        !     this%tflag = .false.

        !     ! Linear Grid
        !     this%xcell=int(grid%nxg*(this%pos%x+grid%xmax)/(2.*grid%xmax))+1
        !     this%ycell=int(grid%nyg*(this%pos%y+grid%ymax)/(2.*grid%ymax))+1
        !     this%zcell=int(grid%nzg*(this%pos%z+grid%zmax)/(2.*grid%zmax))+1

        ! end subroutine circular_beam

        ! subroutine bessel(this, grid)

        !     use gridMod,   only : cart_grid
        !     use constants, only : PI, twoPI
        !     use random,    only : ranu, rang

        !     implicit none

        !     class(photon) :: this
        !     type(cart_grid), intent(IN)    :: grid

        !     real :: tana, r_pos, x0, y0, z0, dist, n

        !     real :: waist, d, raxi, alpha

        !     waist = .5d-1
        !     alpha = 5.
        !     raxi = 12.7
        !     d = 10.e0
        !     this%wavelength = 488d-9
        !     this%fact = twopi/this%wavelength

        !     this%phase = 0.e0
        !     tana = tan(alpha *pi/180.)

        !     call rang(this%xp, this%yp, 0.e0, sqrt(2.)*waist/4.)
        !     r_pos = sqrt(this%xp**2 + this%yp**2)

        !     this%zp = (raxi - r_pos) * tana
        !     this%phase = this%zp * n

        !     x0 = ranu(-grid%xmax, grid%xmax)
        !     y0 = ranu(-grid%xmax, grid%xmax)
        !     z0 = (r_pos * tana) + d + this%zp

        !     dist = sqrt((x0 - this%xp)**2 + (y0 - this%yp)**2 + (z0 - this%zp)**2)

        !     this%phase = this%phase + dist

        !     this%nxp = (x0 - this%xp) / dist
        !     this%nyp = (y0 - this%yp) / dist
        !     this%nzp = -(z0 - this%zp) / dist ! -ve due to way z pos is defined

        !     this%cost = this%nzp
        !     this%sint = sqrt(1.e0 - this%cost**2)

        !     this%phi = atan2(this%nyp, this%nxp)
        !     this%cosp = cos(this%phi)
        !     this%sinp = sin(this%phi)

        !     this%xp = x0
        !     this%yp = y0
        !     this%zp = grid%zmax - grid%delta
        !     this%tflag = .false.
        !     this%xcell = int(grid%nxg * (this%xp + grid%xmax) / (2. * grid%xmax)) + 1
        !     this%ycell = int(grid%nyg * (this%yp + grid%ymax) / (2. * grid%ymax)) + 1
        !     this%zcell = int(grid%nzg * (this%zp + grid%zmax) / (2. * grid%zmax)) + 1

        ! end subroutine bessel

end module photonMod

max_stars_repo_name: lewisfish/signedMCRT

max_issues_repo_name: lewisfish/signedMCRT

max_forks_repo_name: lewisfish/signedMCRT


text:
!TITLE          Projectile Motion                      ProjectileMotion.f90
!    Fortran for Science and Engineering
!COMMENT
!   Objective: Compute the position (x and y co-ordinates) and the velocity
!              (magnitude and direction) of a projectile, given t,
!              the time since launch, u, the launch velocity, a, the
!              initial angle of launch (in degrees), and g,
!              the acceleration due to gravity.
!       Input: -
!      Output: -
!      Author: Chris B. Kirov
!        Date: 31.03.20

program ProjectileMotion
    implicit none

    ! Constants !
    real, parameter :: PI = 3.1415927               ! pi
    real, parameter :: g = 9.81                     ! acceleration due to gravity

    ! Initial conditions !
    real a                                          ! launch angle in degrees
    real u                                          ! launch velocity
    real t                                          ! time of flight

    ! Wanted values !
    real theta                                      ! direction at time t in degrees
    real x                                          ! horizontal displacement
    real y                                          ! vertical displacement
    real vx                                         ! horizontal velocity
    real vy                                         ! vertical velocity
    real v                                          ! resultant velocity

    ! Read input !
    print *, "Type launch angle [degrees]:"
    read *, a

    print *, "Type launch velocity [m/s]:"
    read *, u

    print *, "Type time of flight [s]:"
    read *, t

    ! Calculate wanted values !
    a = a * PI / 180.                               ! convert to radians

    x = u * cos(a) * t
    y = u * sin(a) * t  - g * t * t / 2.0

    vx = u * cos(a)
    vy = u * sin(a) - g * t

    v = sqrt(vx * vx + vy * vy)
    theta = tan(vy / vx) * 180 / PI                 ! directly converted in degrees

    ! Print results !
    print *, "Horizontal displacement, x: ", x, "Vertical displacement, y: ", y
    print *, "Horizontal velocity, Vx: ", vx, "Vertical velocity, Vy: ", vy
    print *, "Resultant velocity magnitude, V: ", v, "Resultant Velocity Direction, Theta: ", theta
end program ProjectileMotion

max_stars_repo_path: Visual Studio 2010/Projects/Chapter22 Exercise 6/7. Fortran/0ProgramInFortran.f90