text:
C     LAST UPDATE 16/04/91
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE GAUSSIAN
      IMPLICIT NONE
C
C Purpose: Generate a 2-D gaussian function
C
      INCLUDE 'COMMON.FOR'
C
C Calls   5: WFRAME , GETVAL , IMDISP , OPNNEW , OUTFIL
C Called by: BSL
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    VALUE(10),XSQ,YSQ,SQNX,SQNY,RNX,RNY
      INTEGER NPIX,NRAST,IRC,IMEM,KPIC,IFRAME
      INTEGER I,J,K,ICENTX,ICENTY,NVAL
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 OFNAM
C
C IRC    : Return code
C IFRAME : Total nos. of frames
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NFRAME : Nos of time frames
C NVAL   : Nos. of numeric values entered
C
      DATA  IMEM/1/ , KPIC/1/ , IFRAME/1/
C
C-----------------------------------------------------------------------
      NPIX = 512
      NRAST = 512
 10   WRITE (IPRINT,1000) NPIX,NRAST
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 50
      IF (IRC.EQ.2) GOTO 10
      IF (NVAL.GT.0) NPIX=INT(VALUE(1))
      IF (NVAL.GT.1) NRAST=INT(VALUE(2))
C
      ICENTX=(NPIX/2)+1
      ICENTY=(NRAST/2)+1
15    WRITE (IPRINT,1010) ICENTX,ICENTY
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 50
      IF (IRC.EQ.2) GOTO 15
      IF (NVAL.GT.0) ICENTX=INT(VALUE(1))
      IF (NVAL.GT.1) ICENTY=INT(VALUE(2))
C
      RNX = 1.0
      RNY = 1.0
20    WRITE (IPRINT,1020)
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 50
      IF (IRC.EQ.2) GOTO 20
      IF (NVAL.GT.0) RNX=VALUE(1)
      IF (NVAL.GT.1) RNY=VALUE(2)
C
C========GENERATE THE FUNCTION
C
      SQNX = (1.0/RNX)*(1.0/RNX)
      SQNY = (1.0/RNY)*(1.0/RNY)
cx      print *,nx,ny,sqnx,sqny
      K=1
      DO 40 I=1,NRAST
         YSQ=(I-ICENTY)*(I-ICENTY)
         DO 30 J=1,NPIX
            XSQ=(J-ICENTX)*(J-ICENTX)
            SP3(K)=EXP(-(SQNX*XSQ + SQNY*YSQ))
cx            print *,k,xsq,ysq,(SQNX*XSQ + SQNY*YSQ),sp3(k)
            K=K+1
30       CONTINUE
40    CONTINUE
C
C==========DISPLAY & OUTPUT FUNCTION
C
      CALL IMDISP (ITERM,IPRINT,SP3,NPIX,NRAST)
      CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
      IF (IRC.NE.0) GOTO 50
      CALL OPNNEW (LUNIT,NPIX,NRAST,IFRAME,OFNAM,IMEM,HEAD1,HEAD2,IRC)
      IF (IRC.NE.0) GOTO 50
      CALL WFRAME (LUNIT,KPIC,NPIX,NRAST,SP3,IRC)
50    CALL FCLOSE (LUNIT)
999   RETURN
C
1000  FORMAT (' Enter nos of pixels and rasters for image',
     &        ' [',I4,',',I4,'] : ',$)
1010  FORMAT (' Enter x,y coordinate for image centre',
     &        ' [',I4,',',I4,'] : ',$)
1020  FORMAT (' Enter x-factor,yfactor: ',$)
      END

ext: f


text:
Joel Juarez is an independent candidate for ASUCD Senate in the Fall 2009 ASUCD election.

 Candidate Statement

Hello everyone! My name is Joel Juarez, and I am running for ASUCD Senate! I am a fourth year Psychology and Chican@ Studies major from Stockton, California.

Since my first year, I have worked actively to improve student life at UC Davis. From working at the Student Recruitment & Retention Center, to Student Housing, to the Education Abroad Center, my experiences working in multiple areas of campus have prepared me to serve the student body in ASUCD! Remember to vote JOEL JUAREZ #1 and Marisol Ornelas & Abrham CastilloRuiz #23!

UCD Involvement / Experience:

 Student Assistant for the Education Abroad Center, 2009Present
 Peer Educator for the Lesbian, Gay, Bisexual, Transgender Resource Center, since 2006
 Resident Advisor for Student Housing, 20082009
 Safe Zone Facilitator, since 2007
 Facilitator/Organizer for Queer People of Color Conference, Spring 2009
 Facilitator, R.E.A.C.H. Retreat, Winter 2009
 ASES Tutor in Woodland Joint Unified School District, 20082009
 Education Abroad Program participant: Buenos Aires, Argentina, Summer 2008
 La Raza Cultural Days Organizing Committee member, Spring 2008
 Gender and Sexuality Coordinator for Yik’al Kuyum in the Student Recruitment and Retention Center, 20072008
 Writing Ambassador through University Writing Program, 20072008
 CrossCultural Center volunteer, 20062008
 Davis Bridge Tutor in Davis Joint Unified School District, 20062008
 Attendee/Facilitator, Chican@/Latin@ Retreat, 2006, 2007 & 2009
 Member, La Familia de UC Davis

Platform Issues:

STUDENT ADVOCATE PROGRAM

UC Davis students who encounter trouble with professors and university officials have no place to turn to for advice. Other universities offer support services for students in need of representation.

I will establish a Student Advocate Program  a nonpartisan group of students which will offer representation, help, and advice to any student or student group involved in a dispute with the University.

The Student Advocates would provide assistance for a broad variety of problems, including conduct violations, grade disputes, enrollment issues, financial aid problems, establishment of residency, discrimination, and harassment. All assistance would be free and confidential!

CULTIVATE STUDENT HOUSING AND ASUCD CONNECTIONS

Resident Advisors are the first point of contact with first year students, so informing them about ASUCD, resource centers and student services throughout campus would allow first year students a smoother transition into the University.

Help enhance the Resident Advisor training by allotting more time for them to get acquainted with resources and services throughout campus.

ACCESSIBILITY TO FINANCIAL INFORMATION

Work with the Financial Aid Office to increase the number of phone lines, window hours and information accessible online.

Push for live chatting options through the Financial Aid website and more diligent training of student staff to maximize services.

ADVOCATE FOR HIV TESTING ON CAMPUS

Due to budget cuts, anonymous HIV testing funding was reduced and is not guaranteed to continue beyond this academic year. Anonymous HIV testing locations are necessary for awareness and information to reach students on this campus.

Work towards allowing anonymous HIV testing to continue at UC Davis and continue to advocate and educate students about the risks associated with the virus.

20091113 15:26:52 nbsp Congratulations! Users/GreatRyan

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


! This file is part of pdfflow
program example

   use, intrinsic :: ISO_C_BINDING, only: C_ptr, c_char
   implicit none

   integer, parameter :: dp = kind(1.d0)

   integer :: pid
   real(dp) :: alpha_s, q2, x, xfx

   character(kind=c_char, len=21) :: ss = "NNPDF31_nlo_as_0118/0"
   character(kind=c_char, len=24) :: pp = "/usr/share/lhapdf/LHAPDF/"

   call mkPDF(ss, pp)

   q2 = 1.65
   x = 0.1
   call alphasq2(q2, alpha_s)

   write(*, '(A, F7.5)')"The value of alpha_s is: ", alpha_s

   write(*, fmt=100)"Value of x*f(x) at q2=", q2, " x=",x
   do pid = -5, 5
      call xfxq2(pid, x, q2, xfx)
      write(*, fmt=200)"Flavour: ", pid, " value: ", xfx
   enddo

100 format (A, F6.2, A, F4.2)
200 format ("    ", A, I0, A, F10.7)

end program


! ###############################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

   MODULE ARPACK_INFO_MSG_Interface

   INTERFACE

      SUBROUTINE ARPACK_INFO_MSG ( SUBNAME, INFO, IPARAM, LWORKL, NEV, NCV )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE SCONTR, ONLY                :  PROG_NAME, FATAL_ERR, NDOFL, WARN_ERR
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE PARAMS, ONLY                :  DARPACK, SUPWARN
      USE MODEL_STUF, ONLY            :  EIG_N2

      IMPLICIT NONE

      CHARACTER(  6*BYTE), INTENT(IN):: SUBNAME            ! Name of subr w/ msg

      INTEGER, INTENT(IN)            :: INFO               ! Error msg number from ARPACK routine to do eigenvalue/vec calc
      INTEGER, INTENT(IN)            :: IPARAM(11)         ! Integer array from subr DSBAND (in module ARPACK_LANCZOS_1)
      INTEGER, INTENT(IN)            :: LWORKL             ! Length of array WORKL in subr dsband
      INTEGER, INTENT(IN)            :: NEV                !
      INTEGER, INTENT(IN)            :: NCV                !

      END SUBROUTINE ARPACK_INFO_MSG

   END INTERFACE

   END MODULE ARPACK_INFO_MSG_Interface


text:
      FUNCTION bessj(n,x)
      INTEGER n,IACC
      REAL bessj,x,BIGNO,BIGNI
      PARAMETER (IACC=40,BIGNO=1.e10,BIGNI=1.e-10)
CU    USES bessj0,bessj1
      INTEGER j,jsum,m
      REAL ax,bj,bjm,bjp,sum,tox,bessj0,bessj1
      if(n.lt.2)pause 'bad argument n in bessj'
      ax=abs(x)
      if(ax.eq.0.)then
        bessj=0.
      else if(ax.gt.float(n))then
        tox=2./ax
        bjm=bessj0(ax)
        bj=bessj1(ax)
        do 11 j=1,n-1
          bjp=j*tox*bj-bjm
          bjm=bj
          bj=bjp
11      continue
        bessj=bj
      else
        tox=2./ax
        m=2*((n+int(sqrt(float(IACC*n))))/2)
        bessj=0.
        jsum=0
        sum=0.
        bjp=0.
        bj=1.
        do 12 j=m,1,-1
          bjm=j*tox*bj-bjp
          bjp=bj
          bj=bjm
          if(abs(bj).gt.BIGNO)then
            bj=bj*BIGNI
            bjp=bjp*BIGNI
            bessj=bessj*BIGNI
            sum=sum*BIGNI
          endif
          if(jsum.ne.0)sum=sum+bj
          jsum=1-jsum
          if(j.eq.n)bessj=bjp
12      continue
        sum=2.*sum-bj
        bessj=bessj/sum
      endif
      if(x.lt.0..and.mod(n,2).eq.1)bessj=-bessj
      return
      END

ext: for

max_stars_repo_path: NR-Functions/Numerical Recipes- Example & Functions/Functions/bessj.for


module mod_hash_map
  implicit none
  integer, parameter :: int_max_value = 2147483647
  integer, parameter :: default_initial_capacity = 16
  integer, parameter :: maximum_capacity = lshift(1, 30)
  real, parameter :: default_load_factor = 0.75

  type t_entry
    integer :: key
    integer :: val
    type(t_entry), pointer :: next => null()
    integer :: hash
  end type

  type t_entry_ptr
    type(t_entry), pointer :: ref => null()
  end type

  type t_hash_map
    type(t_entry_ptr), private, allocatable :: table(:)
    integer :: size = 0
    integer, private :: threshold = int(default_initial_capacity * default_load_factor)
    real, private :: load_factor = default_load_factor
  contains
    procedure :: is_empty => is_empty
    procedure :: is_not_empty => is_not_empty
    procedure :: put => put
    procedure :: get => get
    procedure :: get_or_default => get_or_default
    procedure :: remove => remove
    procedure :: clear => clear
    procedure :: contains_key => contains_key
    procedure :: contains_val => contains_val
  end type

  interface hash_map
    module procedure :: newhm0, newhm1, newhm2
  end interface

contains

  function new_entry(key, val, h) result(res)
    integer, intent(in) :: key
    integer, intent(in) :: val
    integer, intent(in) :: h
    type(t_entry), pointer :: res
    allocate(res)
    res%key = key
    res%val = val
    res%hash = h
  end

  integer function hash_code(i) result(res)
    integer, intent(in) :: i
    res = i
  end

  type(t_hash_map) function newhm0() result(res)
    allocate(res%table(default_initial_capacity))
  end

  type(t_hash_map) function newhm1(initial_capacity) result(res)
    integer, intent(in) :: initial_capacity
    res = newhm2(initial_capacity, default_load_factor)
  end

  type(t_hash_map) function newhm2(initial_capacity, load_factor) result(res)
    integer, intent(in) :: initial_capacity
    real, intent(in) :: load_factor
    integer :: capacity
    if (initial_capacity < 0) then
      capacity = default_initial_capacity
    else
      capacity = 1
      do while (capacity < min(initial_capacity, maximum_capacity))
        capacity = lshift(capacity, 1)
      end do
    end if

    if (load_factor <= 0 .or. load_factor /= load_factor) then
      res%load_factor = default_load_factor
    else
      res%load_factor = load_factor
    end if

    res%threshold = int(capacity * res%load_factor)
    allocate(res%table(capacity))
  end

  integer function shr(i, n) result(res)
    integer, intent(in) :: i, n
    if (n == 0) then
      res = i
    else
      res = rshift(ibclr(rshift(i, 1), 31), n-1)
    end if
  end

  integer function hash(i) result(res)
    integer, intent(in) :: i
    integer :: h
    h = i
    h = xor(h, xor(shr(h, 20), shr(h, 12)))
    res = xor(h, xor(shr(h, 7), shr(h, 4)))
  end

  integer function index_for(h, length) result(res)
    integer, intent(in) :: h, length
    res = and(h, length - 1) + 1
  end

  logical function is_empty(this) result(res)
    class(t_hash_map), intent(in) :: this
    res = this%size == 0
  end

  logical function is_not_empty(this) result(res)
    class(t_hash_map), intent(in) :: this
    res = this%size /= 0
  end

  integer function get(this, key) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: key
    integer :: h
    type(t_entry), pointer :: e
    h = hash(hash_code(key))
    e => this%table(index_for(h, size(this%table)))%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        res = e%val
        return
      end if
      e => e%next
    end do
    res = 0
  end

  integer function get_or_default(this, key, def) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: key
    integer, intent(in) :: def
    integer :: h
    type(t_entry), pointer :: e
    h = hash(hash_code(key))
    e => this%table(index_for(h, size(this%table)))%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        res = e%val
        return
      end if
      e => e%next
    end do
    res = def
  end

  logical function contains_key(this, key) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: key
    type(t_entry), pointer :: e
    e => get_entry(this, key)
    res = associated(e)
  end

  function get_entry(this, key) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: key
    integer :: h
    type(t_entry), pointer :: e
    type(t_entry), pointer :: res
    h = hash(hash_code(key))
    e => this%table(index_for(h, size(this%table)))%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        res => e
        return
      end if
      e => e%next
    end do
    res => null()
  end

  subroutine put(this, key, val)
    class(t_hash_map), intent(inout) :: this
    integer, intent(in) :: key
    integer, intent(in) :: val
    integer :: h, i
    type(t_entry), pointer :: e
    h = hash(hash_code(key))
    i = index_for(h, size(this%table))
    e => this%table(i)%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        e%val = val
        return
      end if
      e => e%next
    end do
    call add_entry(this, key, val, h, i)
  end

  subroutine add_entry(this, key, val, h, idx)
    class(t_hash_map), intent(inout) :: this
    integer, intent(in) :: key
    integer, intent(in) :: val
    integer, intent(in) :: h, idx
    type(t_entry), pointer :: e
    e => this%table(idx)%ref
    this%table(idx)%ref => new_entry(key, val, h)
    this%table(idx)%ref%next => e
    this%size = this%size + 1
    if (this%size >= this%threshold) call resize(this, 2 * size(this%table))
  end

  subroutine resize(this, new_capacity)
    class(t_hash_map), intent(inout) :: this
    integer, intent(in) :: new_capacity
    integer :: capacity, i, j
    type(t_entry), pointer :: e, next
    type(t_entry_ptr) :: table(new_capacity)
    capacity = size(this%table)
    if (capacity == maximum_capacity) then
      this%threshold = int_max_value
      return
    end if

    do j = 1, capacity
      e => this%table(j)%ref
      if (associated(e)) then
        this%table(j)%ref => null()
        do
          next => e%next
          i = index_for(e%hash, new_capacity)
          e%next => table(i)%ref
          table(i)%ref => e
          e => next
          if (.not.associated(e)) exit
        end do
      end if
    end do

    deallocate(this%table)
    allocate(this%table(new_capacity))
    do j = 1, new_capacity
      this%table(j)%ref => table(j)%ref
    end do
    this%threshold = int(new_capacity * this%load_factor)
  end

  subroutine remove(this, key)
    class(t_hash_map), intent(inout) :: this
    integer, intent(in) :: key
    integer :: h, i
    type(t_entry), pointer :: e, prev, next
    h = hash(hash_code(key))
    i = index_for(h, size(this%table))
    prev => this%table(i)%ref
    e => prev
    do while (associated(e))
      next => e%next
      if (e%hash == h .and. e%key == key) then
        this%size = this%size - 1
        if (associated(prev, e)) then
          this%table(i)%ref => next
        else
          prev%next => next
        end if
        return
      end if
      prev => e
      e => next
    end do
  end

  subroutine clear(this)
    class(t_hash_map), intent(inout) :: this
    deallocate(this%table)
    allocate(this%table(default_initial_capacity))
    this%size = 0
  end

  logical function contains_val(this, val) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: val
    integer :: i
    type(t_entry), pointer :: e
    do i = 1, size(this%table)
      e => this%table(i)%ref
      do while (associated(e))
        if (e%val == val) then
          res = .true.
          return
        end if
        e => e%next
      end do
    end do
    res = .false.
  end
end module mod_hash_map


text:
! SPDX-Identifier: MIT
module test_string_functions
    use stdlib_error, only : check
    use stdlib_string_type, only : string_type, assignment(=), operator(==), &
                                    to_lower, to_upper, to_title, reverse
    implicit none

contains

    subroutine test_to_lower_string
        type(string_type) :: test_string, compare_string
        test_string = "To_LoWEr !$%-az09AZ"
        compare_string = "to_lower !$%-az09az"

        call check(to_lower(test_string) == compare_string)

    end subroutine test_to_lower_string

    subroutine test_to_upper_string
        type(string_type) :: test_string, compare_string
        test_string = "To_UpPeR !$%-az09AZ"
        compare_string = "TO_UPPER !$%-AZ09AZ"

        call check(to_upper(test_string) == compare_string)

    end subroutine test_to_upper_string

    subroutine test_to_title_string
        type(string_type) :: test_string, compare_string
        test_string = "_#To tiTlE !$%-az09AZ"
        compare_string = "_#To title !$%-a09az"

        call check(to_title(test_string) == compare_string)

    end subroutine test_to_title_string

    subroutine test_reverse_string
        type(string_type) :: test_string, compare_string
        test_string = "_To ReVerSe !$%-az09AZ   "
        compare_string = "   ZA90za-%$! eSreVeR oT_"

        call check(reverse(test_string) == compare_string)

    end subroutine test_reverse_string

end module test_string_functions

program tester
    use test_string_functions
    implicit none

    call test_to_lower_string
    call test_to_upper_string
    call test_to_title_string
    call test_reverse_string

end program tester

max_stars_repo_name: LKedward/stdlib

max_issues_repo_name: LKedward/stdlib

max_forks_repo_name: LKedward/stdlib


!=====================================================|
program main
!=====================================================|
  use geometry_def, only: time,dt,ns,nd,data_dir
  implicit none

  real(KIND(0.d0)) :: dtout,tend,timep
  logical :: exist
!-----------------------------------------------------|
! make data directory

  data_dir = "data/"
  inquire(file=trim(data_dir),exist=exist)
  if(.not. exist) then
     call system("mkdir "//trim(data_dir))
  endif

!-----------------------------------------------------|
! initial time counter

  dtout = 0.01d0
  time = 0.d0
  tend = 0.1d0
  ns = 0
  nd = 0

!-----------------------------------------------------|
! initial setting

  call model

!-----------------------------------------------------|
! initial I/O

  call io

!-----------------------------------------------------|
! time marching

1000 continue
  call mhd

  timep = time
  time = time + dt
  ns = ns + 1

  if(int(timep/dtout) /= int(time/dtout)) then
     nd = nd + 1
     call io
  endif

  if(time < tend) goto 1000
  write(*,*) "### NORMAL END ###"

  stop
end program main


text:
module proxy_module

    use, intrinsic :: iso_fortran_env, only: int16
    implicit none
    private

    public :: nginx_t, new_nginx_server

    type, abstract :: server_t
    contains
        procedure(server_t_handle_request), deferred :: handle_request
    end type server_t

    abstract interface
        subroutine server_t_handle_request(self, url, method, code, msg)
            import server_t, int16
            class(server_t), intent(inout) :: self
            character(*), intent(in) :: url, method
            integer(int16), intent(out) :: code
            character(:), intent(out), allocatable :: msg
        end subroutine server_t_handle_request
    end interface

    type map_t
        character(:), allocatable :: url
        integer(int16) :: rate_limiter
    end type map_t

    type, extends(server_t) :: nginx_t
        type(application_t), allocatable :: application
        integer(int16) :: max_allowed_request
        type(map_t), allocatable :: map(:)
        ! TODO:
    contains
        procedure :: handle_request => nginx_t_handle_request
        procedure :: check_rate_limiting => nginx_t_check_rate_limiting
    end type nginx_t

    type, extends(server_t) :: application_t
    contains
        procedure :: handle_request => application_t_handle_request
    end type application_t

contains

    type(nginx_t) function new_nginx_server() result(nginx)
        type(map_t), allocatable :: map_(:)
        ! TODO:
        allocate (map_(2))
        map_(1) = map_t(url="/app/status", rate_limiter=0_int16)
        map_(2) = map_t(url="/create/user", rate_limiter=0_int16)

        nginx = nginx_t(application=application_t(), max_allowed_request=2, map=map_) ! TODO:
    end function new_nginx_server

    subroutine nginx_t_handle_request(self, url, method, code, msg)
        class(nginx_t), intent(inout) :: self
        character(*), intent(in) :: url, method
        integer(int16), intent(out) :: code
        character(:), intent(out), allocatable :: msg

        logical :: allowed

        allowed = self%check_rate_limiting(url)

        if (.not. allowed) then
            code = 403_int16
            msg = "Not Allowed"
            return
        end if

        call self%application%handle_request(url, method, code, msg)

    end subroutine nginx_t_handle_request

    logical function nginx_t_check_rate_limiting(self, url) result(allowed)
        class(nginx_t), intent(inout) :: self
        character(*), intent(in) :: url

        integer(int16) :: i

        do i = 1_int16, size(self%map, kind=int16)
            if (self%map(i)%url == url) exit
        end do

        ! i = i - 1_int16

        if (self%map(i)%rate_limiter == 0_int16) then
            self%map(i)%rate_limiter = 1_int16
        end if

        if (self%map(i)%rate_limiter > self%max_allowed_request) then
            allowed = .false.
            return
        end if

        allowed = .true.
        self%map(i)%rate_limiter = self%map(i)%rate_limiter + 1_int16

    end function nginx_t_check_rate_limiting

    subroutine application_t_handle_request(self, url, method, code, msg)
        class(application_t), intent(inout) :: self
        character(*), intent(in) :: url, method
        integer(int16), intent(out) :: code
        character(:), intent(out), allocatable :: msg

        if (url == "/app/status" .and. method == "GET") then
            code = 200_int16
            msg = "Ok"
            return
        end if

        if (url == "/create/user" .and. method == "POST") then
            code = 201_int16
            msg = "User Created"
            return
        end if

        code = 404_int16
        msg = "Not Ok"

    end subroutine application_t_handle_request

end module proxy_module

max_stars_repo_name: zoziha/Fortran-Design-Patterns

max_issues_repo_name: zoziha/Fortran-Design-Patterns

max_forks_repo_name: zoziha/Fortran-Design-Patterns


text:
      subroutine ldgogeom(lhead,ihead,itype,ildgounit,xbinp,ioff0p,
     &                    nfoldp,ngpspp,offsetp,offset2p)
c*GMK
c*** Modifications:
c*** Mod 23 Oct 1992 by pch to start at the beginning of the file on each
c***            shot.  Also revert back to checking for shot number and
c***            shot time being equal,  Sepr line 27 has duplicate shot
c***            numbers.  The line also has dropped shots.
c*** Mod 16 Dec 1992 by GMK (ESPs distance d is actually in 1/10's of meters
c*              d = d/10. Also kill ghost shots THISFLAGSHOT = 3. Also kill
c*               shots w/ bougus bearing if type = 5 (ESP).
c*   Mod 17 Dec 1992 Had a mix-up w/ OS bearing and MS bearing in code -- fixed.
c*   Mod 18 Dec 1992 Place LDGO line # into CDP slot in trace header and fake some CDP trace
c*              #'s to sort on such that the CDP (really ESP) can be gathered.
c*   Mod 15 Apr 1994 ifudgemin so as to allow 1 sec mismatches near minute mark
c*               Oh well, time to CHECK only SHOt #'s  for comparison, everything else is
c*               unreliable over an entire experiment.
c*   Mod 21 Dec 1994 Basically only shot # reliable so...check nav file for shot # only
c*               but will warn user if any mismatch occurs, Yikes!
c  mod July 95 by pch
c change ifudgehour = abs(tthr-ihr)  to ifudgehour = abs(tthr-ihour)
c and ifudgeminute to ifudgemin
c  18 Mar 1997 - add the line3 option so that we don't kill any traces
c                when line3 = 1.  Also set    thisshotflag = 1  when its 2!
c  30 Apr 97 - If type .EQ. -3, then force every shot in the nav file to
c              be 1 (thisshotflag = 1)
c  June 2000 - g77 didn't like line3 being a logical
c
c
c*    The following code was modified from a LDGO program that calculates offset(range)
c*    for various geometries, namely type = 3 (CDP), type = 4 (WAP) and type = 5 (ESP).
c*    These parameters can be calculated assuming one is given a LDGO log file and some
c*    other geometrical information (i.e. gun-antenna offset for both ships etc.....).
c*    To find the proper shot in the log file, it is necessary to know the field shot
c*    number (bytes 245-248 BCD) for trace 0 header which is read during the input process.
c*    The following variables are returned from the log file (binary) and are used to
c*    calculate offset and CDP number (type = 3 or 4):
c*    Navigation file:
c*        info header:   position (4byte words) total size = 1024 bytes
c*                       idirshot1 = 2        1st shot number
c*                       idirshotn = 3        last shot number
c*                       inumrec   = 7        total number of shots
c*                       idirangfact = 19     angle factor (i.e. angle = angle/idirangfact
c*                       ildgoline = 20       LDGO line number
c*
c*        shot headers:  position (4byte words) total size = 256 bytes * number of shots
c*                       msshot = 2            field shot number found in lbuf(3)
c*                       thisshotflag = 5      = 1 if nav ship (i.e Ewing), or = 2 if other ship
c*                       msdeadshot = 6        bad trace, nav ship
c*                       osdeadshot = 7        bad trace, other ship
c*                       ttjd = 9              julian day >
c*                       tthr = 10             hour        >  >  >
c*                       ttmn = 11             min          >  >  use to verify shot
c*                       ttsec = 12            sec           >      an additional check!
c*                       finalrange = 16       ship to ship range (tenths of meteres)
c*                       mscourse = 19         nav ship course
c*                       oscourse = 20         other ship course
c*                       bearostoms = 21       bearing other ship to nav ship
c*                       distcdp1 = 22         distance along nav. line from 5000 m reference point
c*                       mslat = 23            latitude of nav ship (MS)  deg*10**6
c*                       mslon = 24            longitude of nav ship (MS) deg*10**6
c*                       mscdpno = 25          cdp number corresponding to this shot MS
c*                       spcdpbin = 30         cdp bin size meters (*100)

      integer*4 logbuf(256)
      integer*4 ishot, ishotold, itrace, lhead(111),
     &idirshot1,idirshotn, inumrec, idirangfact, ishotpos, numtrys,
     &maxtrys,ildgounit, ishotmis, msshot, thisshotflag, msdeadshot,
     &osdeadshot, finalrange, mscourse, oscourse, bearostoms, distcdp1,
     &mslat, mslon, msmaxcdp, spcdpbin, ttjd, tthr, ttmn, ttsec, type,
     &ilogssh, ilogrsh, ilogstorb, ilogrange, ixsdist , ktrace, istrv,
     &ilogcdpdis, ioffset, icdpno, nfold, ildgoline

      real*4 xbin, ioff0, ngpsp, dag1, dag2, d, theta, phi, ymd,
     &xmd, yda, xda, xxmt, xat, yat, angfact, radeg, range, dist,
     &rsshp, refdist

      integer*2 iday, imin, ihour, isec, ihead(111)

      logical first, first1
c****  line3 on tera has dead trace flag on everything, don't kill any
c****  shots when line3 is set to 1, only kill when line3 is 0
      data first /.true./, maxtrys /10/, first1 /.true./, line3/0/

      save

      type = IABS(itype)
c*    Get variables from the lhead(lbuf) or ihead(ibuf) arrays regarding shot trace
      ishot  = lhead(3)
      itrace = lhead(4)
c*    If same shot, different trace - then skip past log file to savetime
      if (ishot.eq.ishotold) goto 99
      iday   = ihead(80)
      ihour  = ihead(81)
      imin   = ihead(82)
      isec   = ihead(83)

c*    check to see if shot number is zero, if so kill it and exit subroutine
      if (ishot.eq.0 .AND. line3 .EQ. 0 ) then
        ihead(15) = 2
        goto 999
      endif

c*    search through log file to find shot and compare the GMT to assure
c*    that the proper trace is identified

c*    get line variables
      if (first) then
         call podisc( ildgounit, 1, 0)                                  ! rewind
         call rddiscb( ildgounit, logbuf, 1024, istat)
         if (istat .NE. 1024 ) THEN
             PRINT *,' ***  ERROR  ***    Bad ldgo nav file.'
             stop
         ENDIF
c*       get variables form line log header 1024 bytes long
         idirshot1 = logbuf(2)
         idirshotn = logbuf(3)
         inumrec   = logbuf(7)
         idirangfact = logbuf(19)
         ildgoline = logbuf(20)
c*       disable if loop since we don't need info for each shot
c         first = .false.
      endif

c*    look for shot # in log file
c*    skip 1024 bytes (255 4byte words) and nshots*256 bytes (64 4 byte words)  --> ishotpos
c*    if shot = 0 i.e. lhead(3)=0, then go to mute trace end then exit - bad trace
   10 CONTINUE
c*    read nav shot values
      call rddiscb( ildgounit, logbuf, 256, istat )
      if (istat .NE. 256 ) THEN
         PRINT *,' ***  ERROR  *** Could not find shot ',lhead(3),
     &        ' trace ',lhead(4),' in the ldgo nav file.'
         ihead(15) = 2
         RETURN
      ENDIF
c*    set  match variables from nav header and compare to values read in from trace 0
      msshot = logbuf(2)                                                !nav file shot num
      ttjd   = logbuf(9)                                                !time julian day
      tthr   = logbuf(10)                                               !time hour
      ttmn   = logbuf(11)                                               !time minute
      ttsec  = logbuf(12)                                               !time sec
      ifudgesec = abs(ttsec-isec)                                       !sometimes shot tme trace 0 and logfile shots
                                                                        !are off by a second - hence its fudged to be within
                                                                        !1 second of shot time
      ifudgeday = abs(ttjd-iday)                                        !day are sometimes off by 1 too
      ifudgemin = abs(ttmn-imin)                                        ! minute will be off, if off by a sec. near min. mark
      ifudgehour = abs(tthr-ihour)                                        ! check hour mark also

c*    Did we find the proper shot in nav file

      if ( msshot.eq.lhead(3) ) then
c* Lets check for fun and see how off the DSS-240 values are:
c* Write values to screen for trace 1 only
      if ( itrace .eq. 1) then
       if (ifudgeday.ne.0) print*, '***Warning, day mismatch of ',
     &  ifudgeday, ' with navigation file for shot#', msshot
       if (ifudgehour.ne.0) print*, '***Warning, hour mismatch of ',
     &  ifudgehour, ' with navigation file for shot#', msshot
       if (ifudgemin.ne.0) print*, '***Warning, minute mismatch of ',
     &  ifudgemin, ' with navigation file for shot#', msshot
       if (ifudgesec.ne.0) print*, '***Warning, second mismatch of ',
     &  ifudgesec, ' with navigation file for shot#', msshot
      endif

c*   Lamont timing mark on DSS-240 sucks the big one -- not consistent
c*   we will risk for now, not using another check since its not robust enough
c*   will use fudge parameters for now
c*   if so, read variables for particular shot from 256 byte nav. header
         thisshotflag = logbuf(5)                                       !=1, nav; = 2, os
         IF( itype .EQ. -3 ) thisshotflag = 1
         msdeadshot = logbuf(6)                                         != -1 bad nav shot
         osdeadshot = logbuf(7)                                         != -1 bad os shot
         finalrange = logbuf(16)                                        !ship to ship range
         mscourse = logbuf(19)                                          !nav ship course
         oscourse = logbuf(20)                                          !other ship course
         bearostoms = logbuf(21)                                        !bearing other ship to mother ship
         distcdp1 = logbuf(22)                                          !distance to initial cdp nav point
         mslat = logbuf(23)                                             !lat of shot nav ship *10**6
         mslon = logbuf(24)                                             !long of shot nav ship *10**6
         msmaxcdp = logbuf(27)                                          !max num cdps this shot nav ship
         spcdpbin = logbuf(30)                                          !cdp bin size *100
c         print *,(ii,logbuf(ii),ii=1,30)
      else
c*     Basically looks at each value in the LDGO log file until a match is achieved,
c*     or end of file is encountered
         goto 10
      endif

c*    check if type = 3 (cdp) and os ship shots were recorded, then kill os shots or..
c*    check if type = 5 (esp) and ms ship shots were recorded, then kill ms shots
c*    and place bougus range in header (-999999)
99    if (type.eq.3 .and. thisshotflag.eq.2 ) then
         IF( line3 .EQ. 0 ) THEN
             ihead(15) = 2
             lhead(10) = -999999
             goto 999
         ELSE
             thisshotflag = 1
         ENDIF
      else if (type.eq.5 .and. thisshotflag.eq.1.AND. line3 .EQ. 0) then
         ihead(15) = 2
         lhead(10) = -999999
         goto 999
      endif

c*    check to see if bogus bearing is placed in either logbuf(19,20,21)
c*    if so, kill trace and place bougus range in header (-999999)
       if (type .ne. 3 .AND. line3 .EQ. 0 ) then
        if (mscourse.eq.-999999 .or. oscourse.eq.-999999 .or.
     &  bearostoms.eq.-999999) then
          ihead(15) = 2
          lhead(10) = -999999
          goto 999
        endif
       endif

c*    check to see if shot is really DSS - 240 trick shot to get the record length
c*    beyond 19.8 seconds - Will kill traces from ghost shot! If you want 0-40 sec.
c*    of data use SIOSEIS process CAT to concatenate shots (remember there will be
c*    a 2 second gap 19.8-20.0 and 39.8-40.0 DSS - 240 did not record then!
c*    will kill traces and place bogus range in header for now!
      if (type.eq.5 .and. thisshotflag.eq.3 .AND. line3 .EQ. 0 ) then
          ihead(15) = 2
          lhead(10) = -999999
          goto 999
      endif

c*    again check to see if there is a bad trace in log file
      if (thisshotflag.eq.1 .and. msdeadshot.eq.-1.AND.line3.EQ.0) then
         ihead(15) = 2
         goto 999
      elseif (thisshotflag.eq.2.and.osdeadshot.eq.-1.AND.line3.EQ.0)then
         ihead(15) = 2
         goto 999
      endif

c*    we are now going to do the offset and cdp number calculations for type = 3,4 and 5
c*    1st, we define the navigation and shooting parameters from the ldgo geometry file
c*    via sioseis (for both the shooting and navigation ships)

      if (first1) then
	xbin  =	abs(xbinp)                                                   !bin size in meters for cdp.
	ioff0 = abs(float(ioff0p))                                           !recording ship distance antenna to 1st receiver.)
        nfold = abs(nfoldp)                                                  !recording ship # of channels.
        ngpsp = abs(float(ngpspp))                                           !recording ship group spacing.
c*      I've hardwired the istrv value to be 0 for the DSS 240 system
        istrv =	0                                                            !recording ship streamer channel 1, 0-far, 1-near
        dag1 = abs(offsetp)                                                  !navigation ship distance antenna to guns.
        dag2 = abs(offset2p)                                                 !other ship ship distance antenna to guns.
        first1 = .false.
      endif

c*    define the following from appropriate nav log record knowing the shooting and
c*    recording ships.
        ilogssh   = oscourse                                            !shooting ship course
        ilogrsh   = mscourse                                            !recording ship course
        ilogstorb = bearostoms                                          !bearing os to ms.
        ilogrange = finalrange                                          !ship to ship range this shot

      ixsdist = 0
c*    ixdist used for explosive ESP shots - not done today
	if(type.eq.5) then
           ixsdist = 0                                                   !shooting ship extra source distance, set = 0
	endif

c*    reverse bearing to ms to os ship - used for two ship, two streamer work!
c*    recent experiments do not include this geometry - nevertheless is included for future work
	if(thisshotflag.eq.1) then
           ilogstorb=ilogstorb-180                                      !we really want bearing shooting to recording.
	endif

c*    distance from initial navigation point to shot location
          ilogcdpdis = distcdp1                                         !distance along line ms this shot.

c*    offset calculation.
        radeg=3.14159/180.
c*    angfact is used to retrieve more precise angle measurements (usually 100)
        angfact = float(idirangfact)
        if(angfact.eq.0) angfact=1.0
        angfact=1./angfact
        if (thisshotflag.eq.2) then
           d=float(ilogrange)/10.0                                      !ship ship distance (tenths of meters)
           theta=angfact*float(ilogstorb-ilogrsh)*radeg                 !bearing angle between shooting ship and nav. ship
           phi=angfact*float(ilogssh-ilogrsh)*radeg                     !feather angle of shooting ship w/ respect to nav. ship
           ymd=d*sin(theta)                                             !perpendicular projection w/ respect to nav. ship of s-s distance
           xmd=d*cos(theta)                                             !parallel projection w/ respect to nav. ship of s-s distance
           yda=(dag2+float(ixsdist))*sin(phi)                           !perpendicular projection w/ respect to nav. ship of source feathering
           xda=(dag2+float(ixsdist))*cos(phi)                           !parallel projection w/ respect to nav. ship of source feathering
       else
           ymd=0
           xmd=0
           yda=0
           xda=dag1                                                     !airgun to antenna distance nav ship = dag1
       endif
c*    calculate offset w/ respect to streamer channel
        ktrace=itrace
        if(istrv.eq.1) then                                             !streamer channel 1 is near trace, not the case however
           ktrace=nfold-ktrace+1
        endif
        xxmt=ioff0+float(nfold-ktrace)*ngpsp                            !distance from antenna to itrace channel on streamer
        xat=xxmt-xmd-xda
        yat=-ymd-yda
        range=sqrt(xat**2+yat**2)                                       !calculate range using X**2 + Y**2 = Z**2
        if(xat.gt.0) then
           range=-range
        endif
        if(type.ne.5) then                                              !ranges absolute for waps and cdps
           range=abs(range)
        endif

c*      place integer range in segy header
        ioffset= nint(range)                                            !make range an integer
        lhead(10) = ioffset

c*    calculate cdp number (LDGO line number) and pseudo cdp trace number for
c*    ESP binning of ranges i.e. 25 m range increments will have same trace #
c*    which is preferable for SIOSEIS process SORT

      if (type.eq.5) then
        lhead(6) = ildgoline
        lhead(7) = nint(10000 + (ioffset/25.0) )
      endif

c*    calculate cdp number corresponding to log (type 3 and 4)

      if (type.eq.3 .or. type.eq.4) then

	rsshp=0.0

c*    if the shooting ship is not the navigation ship, i.e. thisshotflag = 2
	if(thisshotflag.eq.2) then
	  rsshp= float(ilogrange)/10.0
	endif

c*    if the shooting ship is not the lead ship, i.e. not 1 (2 source, 2 receiver geometry)
	if(thisshotflag.eq.2) then
	  rsshp=-rsshp
	endif

c*    calculate half offset variable
	refdist=float(ioffset)*.5

c*    if the shooting and recording ships are the same or the shooting ship
c*    is the lead ship(1)
	if(thisshotflag.eq.1) then
	  refdist=-refdist
	endif
c	 print *,' refdist=',refdist,' ilogcdpdis=',ilogcdpdis,
c     &   ' rsshp=',rsshp,' dag1=',dag1

c*    midpoint distance away from navigational initial point
        if (thisshotflag.eq.1) then
          dist=float(ilogcdpdis)+rsshp-dag1+refdist
        else
          dist=float(ilogcdpdis)+rsshp-dag2+refdist
        endif

c*    calculate cdp number and place it in segy header
c	print *,' dist=',dist,' ilog=',ilogcdpdis
	icdpno = int((dist+xbin/2.0)/xbin + 1)
        lhead(6) = icdpno

c*    endif to calculate cdp
      endif

c*    put lat, lon, dead trace into segy header,
c*    and ready it to be passed onto next process

      lhead(19) = mslon                                                  !longitude*10**6
      lhead(20) = mslat                                                  !latitude*10**6
      ihead(15) = 1                                                      !good trace

999   ishotold = ishot

      return
      end

max_stars_repo_name: apthorpe/sioseis

max_issues_repo_name: henkart/sioseis

max_forks_repo_name: henkart/sioseis


text:
! This test checks lowering of OpenMP declare simd Directive.

// RUN: not flang-new -fc1 -emit-fir -fopenmp %s 2>&1 | FileCheck %s

subroutine sub(x, y)
  real, intent(inout) :: x, y

  // CHECK: not yet implemented: OpenMPDeclareSimdConstruct
  !$omp declare simd(sub) aligned(x)
  x = 3.14 + y
end

max_stars_repo_name: ornata/llvm-project

max_issues_repo_name: ornata/llvm-project

max_forks_repo_name: ornata/llvm-project


text:
!-----------------------------------------------------------------------
      subroutine w3doxdat(idat,jdow,jdoy,jday)
!$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
!
! SUBPROGRAM: W3DOXDAT       RETURN WEEK DAY, YEAR DAY, AND JULIAN DAY
!   AUTHOR: MARK IREDELL     ORG: WP23       DATE: 98-01-05
!
! ABSTRACT: THIS SUBPROGRAM RETURNS THE INTEGER DAY OF WEEK, THE DAY
!   OF YEAR, AND JULIAN DAY GIVEN AN NCEP ABSOLUTE DATE AND TIME.
!
! PROGRAM HISTORY LOG:
!   98-01-05  MARK IREDELL
!
! USAGE:  CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY)
!
!   INPUT VARIABLES:
!     IDAT       INTEGER (8) NCEP ABSOLUTE DATE AND TIME
!                (YEAR, MONTH, DAY, TIME ZONE,
!                 HOUR, MINUTE, SECOND, MILLISECOND)
!
!   OUTPUT VARIABLES:
!     JDOW       INTEGER DAY OF WEEK (1-7, WHERE 1 IS SUNDAY)
!     JDOY       INTEGER DAY OF YEAR (1-366, WHERE 1 IS JANUARY 1)
!     JDAY       INTEGER JULIAN DAY (DAY NUMBER FROM JAN. 1,4713 B.C.)
!
! SUBPROGRAMS CALLED:
!     IW3JDN         COMPUTE JULIAN DAY NUMBER
!     W3FS26         YEAR, MONTH, DAY FROM JULIAN DAY NUMBER
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
      integer idat(8)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  get julian day and then get day of week and day of year
      jday=iw3jdn(idat(1),idat(2),idat(3))
      call w3fs26(jday,jy,jm,jd,jdow,jdoy)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      end

max_stars_repo_name: GMAO-SI-Team/jedi-stack

max_issues_repo_name: GMAO-SI-Team/jedi-stack


text:
Im a (incoming) firstyear graduate student at UC Davis in Agricultural and Resource Economics. Moving to Davis from the east coast, I am just trying to learn as much as I can about my new home.

20090710 21:43:39 nbsp Hey, Patrick. Welcome to Davis and welcome to the wiki. Good luck in your graduate students grad work.  Users/robinlaughlin


text:
! wind_hk_addr_def.for - tables of wind/waves housekeeping addresses (minor
! frame numbers and associated word indexes)

	include		'wind_hk_def.for'

	! table of hk minor fr.addresses
	integer*4	hk_mf_addr(w_first_core_hk_word:w_last_core_hk_word)

	! table of hk word addresses
	integer*4	hk_word_addr(w_first_core_hk_word:w_last_core_hk_word)

	data		hk_mf_addr/
	1		  4,   4,   9,  14,  14,  19,  24,  24,  29,
	1		 34,  34,  39,  44,  44,  49,  54,  54,  59,
	1		 64,  64,  69,  74,  74,  79,  84,  84,  89,
	1		 94,  94,  99,
	1		104, 104, 109, 114, 114, 119, 124, 124, 129,
	1		134, 134, 139, 144, 144, 149, 154, 154, 159,
	1		164, 164, 169, 174, 174, 179, 184, 184, 189,
	1		194, 194, 199,
	1		204, 204, 209, 214, 214, 219, 224, 224, 229,
	1		234, 234, 239, 244, 244, 249,
	1		 66,  76,  86,  96, 106, 116/
	data		hk_word_addr/
	1		 17,  18,  18,  17,  18,  18,  17,  18,  18,
	1		 17,  18,  18,  17,  18,  18,  17,  18,  18,
	1		 17,  18,  18,  17,  18,  18,  17,  18,  18,
	1		 17,  18,  18,
	1		 17,  18,  18,  17,  18,  18,  17,  18,  18,
	1		 17,  18,  18,  17,  18,  18,  17,  18,  18,
	1		 17,  18,  18,  17,  18,  18,  17,  18,  18,
	1		 17,  18,  18,
	1		 17,  18,  18,  17,  18,  18,  17,  18,  18,
	1		 17,  18,  18,  17,  18,  18,
	1		 18,  18,  18,  18,  18,  18/


text:
C$Procedure ZZRYXSPH ( Intersection of ray and sphere )

      SUBROUTINE ZZRYXSPH ( VERTEX, UDIR, R, XPT, FOUND )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines. Users should not call this routine directly due to the
C     volatile nature of this routine.
C
C     Quickly find the intersection of a ray and a sphere, without
C     performing normal error handling.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     PLANES
C
C$ Keywords
C
C     GEOMETRY
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      VERTEX ( 3 )
      DOUBLE PRECISION      UDIR   ( 3 )
      DOUBLE PRECISION      R
      DOUBLE PRECISION      XPT    ( 3 )
      LOGICAL               FOUND

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     VERTEX,
C     UDIR       I   Vertex and unit length direction vector of ray.
C     R          I   Radius of sphere.
C     XPT        O   Intersection point, if NXPTS = 1.
C     FOUND      O   Flag indicating whether intersection exists.
C
C$ Detailed_Input
C
C     VERTEX,
C     UDIR           are a point and unit-length direction vector that
C                    define a ray in three-dimensional space. The ray
C                    is the set of points in 3-dimensional space
C
C                       { X : X = VERTEX + s*UDIR, s >= 0 }
C
C
C     R              is the radius of a sphere. The sphere is centered
C                    at the origin.
C
C$ Detailed_Output
C
C     XPT            is the point of intersection nearest to the ray's
C                    vertex of the input ray and sphere, if the
C                    intersection exists. Otherwise, XPT is undefined.
C
C     FOUND          is a local flag that is .TRUE. if and only if
C                    the input ray intersects the sphere.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  The ray's direction vector must have unit length. The
C         outputs of this routine will be invalid otherwise.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine performs a simplified version of the ray-ellipsoid
C     intersection computation performed by SURFPT; this routine works
C     with spheres only. This routine dispenses with error handling and
C     nuanced handling of near- singular geometry in return for speed.
C
C     On a PC/Linux/gfortran/64bit platform on which this routine
C     was tested, it ran about 5 times faster than the public
C     SPICELIB routine SURFPT.
C
C     This routine is meant to be used only by the DSK subsystem.
C
C$ Examples
C
C     See usage in ZZRYXLAT.
C
C$ Restrictions
C
C     1) All inputs must be checked by the caller; they are not checked
C        here.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 11-JAN-2016 (NJB)
C
C-&

C$ Index_Entries
C
C     intersection of ray and sphere
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDOT

C
C     Local variables
C
      DOUBLE PRECISION      CPAR
      DOUBLE PRECISION      PERP   ( 3 )
      DOUBLE PRECISION      PMAG2
      DOUBLE PRECISION      R2
      DOUBLE PRECISION      S
      DOUBLE PRECISION      VMAG2

      FOUND = .FALSE.

C
C     Find the component of VERTEX orthogonal to UDIR. If the magnitude
C     of this component exceeds R, there's no intercept.
C
      CPAR = VDOT ( VERTEX, UDIR )

      CALL VLCOM ( 1.D0, VERTEX, -CPAR, UDIR, PERP )

      PMAG2 = VDOT( PERP, PERP )
      R2    = R * R

C
C     Compare squares of magnitudes, rather than magnitudes, for
C     efficiency.
C
      IF ( PMAG2 .GT. R2 ) THEN
         RETURN
      END IF

      S     = SQRT (  MAX( 0.D0,  R2-PMAG2 )  )

      VMAG2 = VDOT(VERTEX,VERTEX)

      IF ( VMAG2 .GT. R2 ) THEN
C
C        If the magnitude of the vertex exceeds R, the vertex is
C        outside the sphere. Above, we have compared squares of
C        magnitudes for efficiency.
C
         IF ( CPAR .GT. 0.D0 ) THEN
C
C           The ray points away from the sphere; there can be no
C           intersection.
C
            RETURN

         END IF
C
C        Given that an intercept exists, we can find it between VERTEX
C        and VPERP by following -UDIR from PERP towards VERTEX.
C
         XPT(1) = PERP(1) - S*UDIR(1)
         XPT(2) = PERP(2) - S*UDIR(2)
         XPT(3) = PERP(3) - S*UDIR(3)

      ELSE IF ( VMAG2 .LT. R2 ) THEN
C
C        The vertex is inside the sphere. We can calculate the exit
C        point by using PERP as a vertex.
C
         XPT(1) = PERP(1) + S*UDIR(1)
         XPT(2) = PERP(2) + S*UDIR(2)
         XPT(3) = PERP(3) + S*UDIR(3)

      ELSE
C
C        PERP is the sole intercept.
C
         XPT(1) = PERP(1)
         XPT(2) = PERP(2)
         XPT(3) = PERP(3)

      END IF

      FOUND = .TRUE.

      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
      program f
      implicit none
      integer i
      integer, parameter :: Inf = 5
      do i = 1, 10
         select case (i)
         case (:Inf)
            write (*,10) i

         case (Inf+1:)
            write (*,10) -i
         end select
      end do

 10   format(I4)
      end program f