text:
module quad_tree_mesh
	use precision_specs
	implicit none

	type :: qtree_node
		real(dp), dimension(1:2, 1:2) :: bounds
		real(dp), dimension(1:2) :: centroid
		real(dp) :: h
		integer :: idx
		logical :: need_to_refine

		real(dp) :: previous_val
		real(dp) :: current_val

		! Pointer to the parent node.
		type(qtree_node), pointer :: parent

		! Neighbors for the given node.
		type(qtree_node), pointer :: north
		type(qtree_node), pointer :: south
		type(qtree_node), pointer :: east
		type(qtree_node), pointer :: west

		! Children for the given node.
		type(qtree_node), pointer :: nechild
		type(qtree_node), pointer :: nwchild
		type(qtree_node), pointer :: swchild
		type(qtree_node), pointer :: sechild
	end type qtree_node

	type :: qtree_mesh
		type(qtree_node), pointer :: root
		integer :: tree_size = 0

		integer, dimension(1:4) :: boundary_flags

		! Pointers for the coefficient and right-hand-side functions.
		procedure, pointer :: coefficient
		procedure, pointer :: right_hand_side
	end type qtree_mesh

	contains

	!--------------------------------------------------------------!
	! Subroutines for working with the individual quad tree nodes. !
	!--------------------------------------------------------------!

	subroutine qtree_node_init(node, parent, bnds, step_size, indx)
		type(qtree_node), intent(inout) :: node
		type(qtree_node), intent(in) :: parent
		real(dp), intent(in), dimension(1:2, 1:2) :: bnds
		real(dp), intent(in) :: step_size
		integer, intent(in) :: indx

		node%bounds = bnds
		node%centroid = 0.5 * sum(bnds, 2)
		node%h = step_size
		node%idx = indx

		node%previous_val = 0.0_dp
		node%current_val = 0.0_dp

		! Set the parent for the given node.
		node%parent => parent

		! Neighbors for the given node.
		node%north = NULL()
		node%south = NULL()
		node%east = NULL()
		node%west = NULL()

		! Children for the given node.
		node%nechild = NULL()
		node%nwchild = NULL()
		node%swchild = NULL()
		node%sechild = NULL()
	end subroutine qtree_node_init

	subroutine qtree_node_refine(node)
		type(qtree_node), intent(inout) :: node
		real(dp) :: bnds

		! Allocate and initialize all of the children.
		allocate(qtree_node%children)

		! Initialize the child in the northeast quadrant.
		bnds(1, :) = (/ node%bounds(1, 1) + node%h / 2.0, node%bounds(1, 2) /)
		bnds(2, :) = (/ node%bounds(2, 1) + node%h / 2.0, node%bounds(2, 2) /)
		qtree_node_init(node%nechild, node, bnds, node%h / 2.0, 4 * node%idx - 2)

		! Initialize the child in the northwest quadrant.
		bnds(1, :) = (/ node%bounds(1, 1), node%bounds(1, 1) + node%h / 2.0 /)
		bnds(2, :) = (/ node%bounds(2, 1) + node%h / 2.0, node%bounds(2, 2) /)
		qtree_node_init(node%nwchild, node, bnds, node%h / 2.0, 4 * node%idx - 1)

		! Initialize the child in the southwest quadrant.
		bnds(1, :) = (/ node%bounds(1, 1), node%bounds(1, 1) + node%h / 2.0 /)
		bnds(2, :) = (/ node%bounds(2, 1), node%bounds(2, 1) + node%h / 2.0 /)
		qtree_node_init(node%swchild, node, bnds, node%h / 2.0, 4 * node%idx)

		! Initialize the child in the southeast quadrant.
		bnds(1, :) = (/ node%bounds(1, 1) + node%h / 2.0, node%bounds(1, 2) /)
		bnds(2, :) = (/ node%bounds(2, 1) + node%h / 2.0, node%bounds(2, 2) /)
		qtree_node_init(node%sechild, node, bnds, node%h / 2.0, 4 * node%idx + 1)
	end subroutine qtree_node_refine

	!
	! Subroutine that checks whether or not a node has children. Quad tree
	! nodes either have no children or all four, so we can aribitrarily check
	! whether or not once of the children is associated to satisfy this.
	!
	function qtree_node_is_leaf(node) result(is_leaf)
		type(qtree_node), intent(in) :: node
		logical :: is_leaf

		is_leaf = .not. associated(node%nechild)
	end function qtnode_is_leaf

	!---------------------------------------------------------!
	! Subroutines for working with the quad tree mesh proper. !
	!---------------------------------------------------------!

	subroutine qtree_mesh_refine_global(qtree)
		type(qtree_mesh), intent(inout) :: qtree
		type(qtree_node), pointer :: next, prev

		if(associated(qtree%root)) then
			prev => null()
			next => qtree%root

			while(associated(next))

				if(qtree_is_leaf(next)) then
					! Once we've hit a leaf, refine it, then move up.
					call qtree_node_refine(next)

					! Set the pointers to move back up the tree.
					prev => next
					next => next%parent
				else
					! In this case, we will either move to the next available child or up the tree.
					if(associated(prev, node%nechild)) then
						prev => next
						next => node%nwchild
					else if(associated(prev, node%nwchild)) then
						prev => next
						next => node%swchild
					else if(associated(prev, node%swchild)) then
						prev => next
						next => node%sechild
					else
						prev = next
						next => next%parent
					end if
				end if

			end while
		end if
	end subroutine qtree_refine_global

	subroutine qtree_refine_local(qtree)
		type(qtree_mesh), intent(inout) :: qtree
		type(qtree_node), pointer :: next, prev

		if(associated(qtree%root)) then
			prev => null()
			next => qtree%root

			while(associated(next))

				if(qtree_node_is_leaf(next) .and. next%need_to_refine) then
					! Once we've hit a leaf that is flagged for refinement, refine it, then move up.
					call qtree_node_refine(next)

					! Set the pointers to move back up the tree.
					prev => next
					next => next%parent
				else
					! In this case, we will either move to the next available child or up the tree.
					if(associated(prev, node%nechild)) then
						prev => next
						next => node%nwchild
					else if(associated(prev, node%nwchild)) then
						prev => next
						next => node%swchild
					else if(associated(prev, node%swchild)) then
						prev => next
						next => node%sechild
					else
						prev = next
						next => next%parent
					end if
				end if

			end while
		end if
	end subroutine qtree_refine_local

end module

max_stars_repo_name: bbqp/multigrid

max_issues_repo_name: bbqp/multigrid

max_forks_repo_name: bbqp/multigrid


text:
!***********************************************************************
! Distributes solar radiation to each HRU and estimates missing solar
! radiation data using a relation between solar radiation and cloud cover.
! Declared Parameters
!     ccov_slope, ccov_intcp, radj_sppt, radj_wppt, basin_solsta
!     crad_coef, crad_exp, radmax, ppt_rad_adj, rad_conv, hru_solsta
!RSR: 03/31/2008
!RSR: Warning, summer is based on equinox of Julian days 79 to 265 in
!RSR:          Northern hemisphere and Julian day 265 to 79 in Southern
!***********************************************************************
      MODULE PRMS_CCSOLRAD
        IMPLICIT NONE
        ! Local Variables
        INTEGER, SAVE :: Observed_flag
        CHARACTER(LEN=8), SAVE :: MODNAME
        ! Declared Variables
        DOUBLE PRECISION, SAVE :: Basin_radadj, Basin_cloud_cover
        REAL, SAVE, ALLOCATABLE :: Cloud_radadj(:), Cloud_cover_hru(:)
        ! Declared Parameters
        REAL, SAVE, ALLOCATABLE :: Crad_coef(:, :), Crad_exp(:, :)
        REAL, SAVE, ALLOCATABLE :: Ccov_slope(:, :), Ccov_intcp(:, :)
      END MODULE PRMS_CCSOLRAD
!***********************************************************************
      INTEGER FUNCTION ccsolrad()
      USE PRMS_CCSOLRAD
      USE PRMS_MODULE, ONLY: Process, Print_debug, Nhru, Nsol
      USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_area, &
     &    Basin_area_inv, NEARZERO
      USE PRMS_CLIMATEVARS, ONLY: Swrad, Basin_orad, Orad_hru, &
     &    Rad_conv, Hru_solsta, Basin_horad, Basin_potsw, Basin_solsta, Orad, Hru_ppt, &
     &    Tmax_hru, Tmin_hru, Solsta_flag, Radj_sppt, Radj_wppt, Ppt_rad_adj, Radmax
      USE PRMS_SOLTAB, ONLY: Soltab_potsw, Soltab_basinpotsw, Hru_cossl, Soltab_horad_potsw
      USE PRMS_SET_TIME, ONLY: Jday, Nowmonth, Summer_flag
      USE PRMS_OBS, ONLY: Solrad
      IMPLICIT NONE
! Functions
      INTRINSIC DBLE
      INTEGER, EXTERNAL :: declparam, getparam, declvar
      EXTERNAL :: read_error, print_module, print_date
! Local Variables
      INTEGER :: j, jj, k
      REAL :: pptadj, radadj, ccov
      CHARACTER(LEN=80), SAVE :: Version_ccsolrad
!***********************************************************************
      ccsolrad = 0

      IF ( Process(:3)=='run' ) THEN
!rsr using julian day as the soltab arrays are filled by julian day
        Basin_horad = Soltab_basinpotsw(Jday)
        Basin_potsw = 0.0D0
        Basin_orad = 0.0D0
        Basin_radadj = 0.0D0
        Basin_cloud_cover = 0.0D0
        DO jj = 1, Active_hrus
          j = Hru_route_order(jj)

          ! determine radiation adjustment due to precipitation
          IF ( Hru_ppt(j)>Ppt_rad_adj(j,Nowmonth) ) THEN
            IF ( Summer_flag==1 ) THEN
              pptadj = Radj_sppt(j)
            ELSE
              pptadj = Radj_wppt(j) ! Winter
            ENDIF
          ELSE
            pptadj = 1.0
          ENDIF

          ccov = Ccov_slope(j, Nowmonth)*(Tmax_hru(j)-Tmin_hru(j)) + Ccov_intcp(j, Nowmonth)
          IF ( ccov<0.0 ) THEN
            ccov = 0.0
          ELSEIF ( ccov>1.0 ) THEN
            ccov = 1.0
          ENDIF
          Cloud_cover_hru(j) = ccov
          Basin_cloud_cover = Basin_cloud_cover + DBLE( ccov*Hru_area(j) )

          radadj = Crad_coef(j, Nowmonth) + &
     &             (1.0-Crad_coef(j,Nowmonth))*((1.0-Cloud_cover_hru(j))**Crad_exp(j,Nowmonth))
          IF ( radadj>Radmax(j,Nowmonth) ) radadj = Radmax(j, Nowmonth)
          Cloud_radadj(j) = radadj*pptadj
          Basin_radadj = Basin_radadj + DBLE( Cloud_radadj(j)*Hru_area(j) )

          Orad_hru(j) = Cloud_radadj(j)*SNGL( Soltab_horad_potsw(Jday,j) )
          Basin_orad = Basin_orad + DBLE( Orad_hru(j)*Hru_area(j) )
          IF ( Solsta_flag==1 ) THEN
            k = Hru_solsta(j)
            IF ( k>0 ) THEN
              IF ( Solrad(k)<0.0 .OR. Solrad(k)>10000.0 ) THEN
                IF ( Print_debug>-1 ) THEN
                  PRINT *, 'WARNING, measured solar radiation missing, HRU:', j, '; station:', k, '; value computed'
                  CALL print_date(1)
                ENDIF
              ELSE
                Swrad(j) = Solrad(k)*Rad_conv
                Basin_potsw = Basin_potsw + DBLE( Swrad(j)*Hru_area(j) )
                CYCLE
              ENDIF
            ENDIF
          ENDIF
          Swrad(j) = SNGL( Soltab_potsw(Jday, j)*DBLE(Cloud_radadj(j))/Hru_cossl(j) )
          Basin_potsw = Basin_potsw + DBLE( Swrad(j)*Hru_area(j) )
        ENDDO
        Basin_orad = Basin_orad*Basin_area_inv
        Basin_radadj = Basin_radadj*Basin_area_inv
        IF ( Observed_flag==1 ) THEN
          Orad = Solrad(Basin_solsta)*Rad_conv
        ELSE
          Orad = SNGL( Basin_orad )
        ENDIF
        Basin_potsw = Basin_potsw*Basin_area_inv
        Basin_cloud_cover = Basin_cloud_cover*Basin_area_inv

      ELSEIF ( Process(:4)=='decl' ) THEN
        Version_ccsolrad = 'ccsolrad.f90 2016-05-10 18:52:00Z'
        CALL print_module(Version_ccsolrad, 'Solar Radiation Distribution', 90)
        MODNAME = 'ccsolrad'

        ALLOCATE ( Cloud_radadj(Nhru) )
        IF ( declvar(MODNAME, 'cloud_radadj', 'nhru', Nhru, 'real', &
     &       'Radiation adjustment for cloud cover of each HRU', &
     &       'decimal fraction', Cloud_radadj)/=0 ) CALL read_error(3, 'cloud_radadj')

        IF ( declvar(MODNAME, 'basin_radadj', 'one', 1, 'double', &
     &       'Basin area-weighted average radiation adjustment for cloud cover', &
     &       'decimal fraction', Basin_radadj)/=0 ) CALL read_error(3, 'basin_radadj')

        ALLOCATE ( Cloud_cover_hru(Nhru) )
        IF ( declvar(MODNAME, 'cloud_cover_hru', 'nhru', Nhru, 'real', &
     &       'Cloud cover proportion of each HRU', &
     &       'decimal fraction', Cloud_cover_hru)/=0 ) CALL read_error(3, 'cloud_cover_hru')

        IF ( declvar(MODNAME, 'basin_cloud_cover', 'one', 1, 'double', &
     &       'Basin area-weighted average cloud cover proportion', &
     &       'decimal fraction', Basin_cloud_cover)/=0 ) CALL read_error(3, 'basin_cloud_cover')

        ! Declare Parameters
        ALLOCATE ( Crad_coef(Nhru,12) )
        IF ( declparam(MODNAME, 'crad_coef', 'nhru,nmonths', 'real', &
     &       '0.4', '0.1', '0.7', &
     &       'Coefficient in cloud cover-solar radiation relationship', &
     &       'Coefficient(B) in Thompson(1976) equation;' // &
     &       ' varies by region, contour map of values in reference', &
     &       'none')/=0 ) CALL read_error(1, 'crad_coef')
        ALLOCATE ( Crad_exp(Nhru,12) )
        IF ( declparam(MODNAME, 'crad_exp', 'nhru,nmonths', 'real', &
     &       '0.61', '0.2', '0.8', &
     &       'Exponent in cloud cover-solar radiation relationship', &
     &       'Exponent(P) in Thompson(1976) equation', &
     &       'none')/=0 ) CALL read_error(1, 'crad_exp')

        ALLOCATE ( Ccov_slope(Nhru,12) )
        IF ( declparam(MODNAME, 'ccov_slope', 'nhru,nmonths', 'real', &
     &       '-0.13', '-0.5', '-0.01', &
     &       'Slope in temperature cloud cover relationship', &
     &       'Monthly (January to December) coefficient in cloud-cover relationship', &
     &       'none')/=0 ) CALL read_error(1, 'ccov_slope')

        ALLOCATE ( Ccov_intcp(Nhru,12) )
        IF ( declparam(MODNAME, 'ccov_intcp', 'nhru,nmonths', 'real', &
     &       '1.83', '0.0', '5.0', &
     &       'Intercept in temperature cloud cover relationship', &
     &       'Monthly (January to December) intercept in cloud-cover relationship', &
     &       'none')/=0 ) CALL read_error(1, 'ccov_intcp')

      ELSEIF ( Process(:4)=='init' ) THEN
! Get parameters
        IF ( getparam(MODNAME, 'crad_coef', Nhru*12, 'real', Crad_coef)/=0 ) CALL read_error(2, 'crad_coef')
        IF ( getparam(MODNAME, 'crad_exp', Nhru*12, 'real', Crad_exp)/=0 ) CALL read_error(2, 'crad_exp')
        IF ( getparam(MODNAME, 'ccov_slope', Nhru*12, 'real', Ccov_slope)/=0 ) CALL read_error(2, 'ccov_slope')
        IF ( getparam(MODNAME, 'ccov_intcp', Nhru*12, 'real', Ccov_intcp)/=0 ) CALL read_error(2, 'ccov_intcp')

        Cloud_radadj = 0.0
        Basin_radadj = 0.0D0
        Cloud_cover_hru = 0.0
        Basin_cloud_cover = 0.0D0

        Observed_flag = 0
        IF ( Nsol>0 .AND. Basin_solsta>0 ) Observed_flag = 1

      ENDIF

      END FUNCTION ccsolrad

max_stars_repo_name: iyanuobidele/prms-on-pegasus

max_issues_repo_name: iyanuobidele/prms-on-pegasus

max_forks_repo_name: iyanuobidele/prms-on-pegasus


text:
C
C	$Id: ggdp.f,v 1.5 2008-07-27 00:20:57 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE GGDP(N,PX,PY,PRIMID,LDR,DATREC)
C
C  GENERALIZED DRAWING PRIMITIVE
C
      INTEGER EGDP
      PARAMETER (EGDP=17)
C
      include 'gkscom.h'
C
      INTEGER N,PRIMID,LDR
      REAL PX(N),PY(N)
      CHARACTER*80 DATREC(LDR)
C
C  Check if GKS is in the proper state.
C
      CALL GZCKST(5,EGDP,IER)
      IF (IER .NE. 0) RETURN
C
C  Check that the number of points is valid.
C
      IF (.NOT.(N.GE.1)) THEN
        ERS = 1
        CALL GERHND(100,EGDP,ERF)
        ERS = 0
        RETURN
      ENDIF
C
C  Set function code and put out the real arrays across the
C  workstation interface.  Flag conversion to NDC space.
C  ID(1) contains the GDP identifier.
C  If ID(2)=0, then no data record will be shipped.  If
C  ID(2)=1, then the data record will be shipped via
C  the first workstation invocation subsequent to the
C  completion of sending the real arrays, i.e. the continuation
C  flag for sending over the real arrays will be set to zero
C  and the data record will be sent across the interface
C  completely independently as the next transmission.
C
      FCODE = 16
C
C  Set up flag in ID(2) to indicate if a data record is to follow
C  sending over the real arrays.
C
      CALL GZROI(0)
      IL1 = 2
      IL2 = 2
      ID(1) = PRIMID
      IF (LDR.GT.0) THEN
        ID(2) = 1
      ELSE
        ID(2) = 0
      ENDIF
C
C  Send over the real arrays.
C
      NPTOT = N
      CALL GZPUTR(NPTOT,N,PX,PY,1,IER)
      RERR = IER
      IF (RERR.NE.0) THEN
        ERS = 1
        CALL GERHND(RERR,EGDP,ERF)
        ERS = 0
        RETURN
      ENDIF
C
C  Send over the data record if there is one (recall that the
C  string length of STR is divisible by 80).
C
      IF (ID(2) .EQ. 1) THEN
        IF (LDR. EQ. 1) THEN
          CONT = 0
          STRL1 = 80
          STRL2 = 80
          STR(1:80) = DATREC(1)
          CALL GZTOWK
          IF (RERR.NE.0) THEN
            ERS = 1
            CALL GERHND(RERR,EGDP,ERF)
            ERS = 0
            RETURN
          ENDIF
        ELSE
C
C     SEND OVER THE DATA RECORD 80 CHARACTERS AT A TIME
C
          CONT = 1
          STRL1 = 80*LDR
          STRL2 = 80
          LDRM1 = LDR-1
          DO 200 I=1,LDRM1
            IF (I .GT. 1) IL2 = 0
            STR(1:80) = DATREC(I)
            CALL GZTOWK
            IF (RERR.NE.0) THEN
              ERS = 1
              CALL GERHND(RERR,EGDP,ERF)
              ERS = 0
              RETURN
            ENDIF
  200     CONTINUE
          CONT = 0
          STR(1:80) = DATREC(LDR)
          CALL GZTOWK
          IF (RERR.NE.0) THEN
            ERS = 1
            CALL GERHND(RERR,EGDP,ERF)
            ERS = 0
            RETURN
          ENDIF
        ENDIF
      ENDIF
C
      RETURN
      END

ext: f

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
!==============================================================================!
  subroutine Levenshtein_Distance(s, t)
!------------------------------------------------------------------------------!
!   For all i and j, d[i,j] will hold the Levenshtein distance between the     !
!   first "i" characters of "s" and the first "j" characters of "t".           !
!                                                                              !
!   Check for details here: https://tinyurl.com/y857p2hf                       !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  character(*) :: s, t  ! source and target strings
!-----------------------------------[Locals]-----------------------------------!
  integer              :: i, j, m, n, cost
  integer, allocatable :: d(:,:)
!==============================================================================!

  m = len_trim(s)
  n = len_trim(t)

  ! Declare int d[0..m, 0..n], and set each element in d to zero
  allocate(d(0:m, 0:n));  d(:,:) = 0

  ! Source prefixes can be transformed into ...
  ! ... empty string by dropping all characters
  do i = 1, m
    d(i, 0) = i
  end do

  ! Target prefixes can be reached from empty ...
  ! ... source prefix by inserting every character
  do j = 1, n
    d(0, j) = j
  end do

  do j = 1, n
    do i = 1, m
      if(s(i:i) .eq. t(j:j)) then
        cost = 0
      else
        cost = 1
      end if
      d(i, j) = min(d(i-1, j  ) + 1,           &   ! deletion
                    d(i,   j-1) + 1,           &   ! insertion
                    d(i-1, j-1) + cost)      ! substitution
    end do
  end do

  ! do j = 0, n
  !   write(*,'(999i4)'), d(0:m, j)
  ! end do

  print *, '# Distance between ', trim(s) , ' and ', trim(t), ' is ', d(m,n)

  end subroutine

!==============================================================================!
  program Levenshtein_Distance_Demo
!------------------------------------------------------------------------------!
  implicit none
!-----------------------------------[Locals]-----------------------------------!
  character(len=80) :: from_file, from_database
!==============================================================================!

  from_file     = "KITTEN"
  from_database = "SITTING"
  call Levenshtein_Distance(from_file, from_database)

  from_file     = "JUMBO"
  from_database = "DUMBO"
  call Levenshtein_Distance(from_file, from_database)

  from_file     = "NUMBER_OF_TIME_STEPS"
  from_database = "NUBER_OF_TIME_STEP"
  call Levenshtein_Distance(from_file, from_database)

  from_file     = "PROBLEM_NAME"
  from_database = "PRUBLEM_NAME"
  call Levenshtein_Distance(from_file, from_database)

  end program

max_issues_repo_name: EdinSmartLab/T-Flows

max_forks_repo_name: EdinSmartLab/T-Flows


text:
!! R521 assumed-size-spec
!    [ explicit-shape-spec , ] ... [ lower-bound : ] *

subroutine assumed_shape(bar, truth)
  integer bar(2:6,5:*)
3 Real truth(31,41,*)
end subroutine

max_stars_repo_name: ouankou/rose

max_issues_repo_name: WildeGeist/rose

max_forks_repo_name: WildeGeist/rose


text:
/* Examples for testing */

x/;
x;

λ x. x;
(λ x. x) (λ x. x x);

lambda x. x;
(lambda x. x) (lambda x. x x);

max_stars_repo_name: anatolat/untyped-lambda

max_issues_repo_name: anatolat/untyped-lambda

max_forks_repo_name: anatolat/untyped-lambda


text:
fl

1 wconstant build_httpserver

\
\ HTTP CONFIG PARAMETERS BEGIN
\

[ifndef $S_ip_httpport
d_8080 wconstant $S_ip_httpport	\ port 8080
]
\
\ uncomment this to enable http debugging
\
\ 1 wconstant http_debug

\
\ HTTP CONFIG PARAMETERS END
\

\ decimal ( -- ) set the base for decimal
[ifndef decimal
: decimal
	hA base W!
;
]

: _ht_filelen
	EW@
;

: _ht_cd drop ;

: _ht_find
	_fsfind
;

: _ht_read
	_fsread
;

: _ht_readblk
\
\ read 3 bytes into t0, t1 and process
	dup t0 h3 _fsrd
	t1 C@ + 2+ 1+ t0 W@ bounds
	do
\ align to page
		fsps i fsps 1- and -
\ only get what we need
		ibound i - min
\ read the bytes
		i pad h2 ST@ _fsrd
\ emit them
		pad over .str
	+loop
	padbl
;

wvariable fspservercog
wvariable fspcog
wvariable chunkercog

wvariable reqstatus 0 reqstatus W!

lockdict wvariable reqdata d_126 allot freedict

[ifdef http_debug
wvariable http_debug 7 http_debug W!

\ debug bit definitions
\ h01 - high level word entry and exit
\ h02 - fsp code
\ h04 - chunker output

: dbglock 7 lock ;
: dbgunlock 7 unlock ;

\ _dbg_mem ( addr count -- )
\ : _dbg_mem
\	c" c~h22 " .concstr
\	bounds
\	do
\		i C@ dup h20 h7E between
\		if
\			.conemit
\		else
\			c" ~h" .concstr
\			base W@ swap hex .conbyte base W!
\		then
\	loop
\	c" ~h22" .concstr .concr
\
\ ;

\ _http_debugmsg ( cstr cstr -- )
: _http_debugmsg
	http_debug W@
	if
		dbglock
		c" COG:" .concstr cogid .con swap .concstr bl .conemit
		dup 0 d255 between
		if
			.con
		else
			.concstr
		then

\		.concr
\		c"    PAD: " .concstr pad padsize _dbg_mem
\		c"   TBUF: " .concstr tbuf d32 _dbg_mem
 		 bl .conemit .const?
\		8 0 do
\			i dup .con cogio dup .conword bl .conemit 2+ W@ .conword bl .conemit
\		loop
\		.concr
\
		dbgunlock
	else
		2drop
	then
;

]

\ ip_SOCKhttp ( n1 -- ) n1 - the socket/cog to restart as an http socket
: ip_SOCKhttp
	dup 0 $S_ip_numsock 1- between
	if
		dup ip_SOCKreset drop				\ reset the socket
		dup iodis
		dup cogreset h80 delms				\ reset the cog
		hA over cogstate orC!				\ prompts, errors off
		$S_ip_httpport over ip_SOCKlistenport W!		\ set the port
\ server connect on, noexpandcr
		h07 over ip_SOCKsendreq drop
		h13 over ip_SOCKsendreq drop

		c" httpserver" over cogx
\		drop
\	else
\		drop
	then
	drop
;

\ httpabort ( -- )
: httpabort
	-1 h01 h11 h10 cogid ip_SOCKsendmultiplereq drop	\ flush output, flush input, then disconnect
;
\ _wnfcog ( -- cog ) wait for a free cog
[ifndef _wnfcog
: _wnfcog
	h_100 0
	do
		(nfcog) 0=
		if
			leave
		then
		drop
		1 delms
	loop
	nfcog
;
\
\
\ httpserver ( -- ) monitors for http requests and responds accordingly
: httpserver
	c" HTTP SERVER" cds W!
	h4 state andnC!
	cogid 0 $S_ip_cog cogid (ioconn)
	h_100 delms
	lockdict
		_wnfcog dup fspservercog W!
		h4 over cogstate andnC!
		hA over cogstate orC!
		c" HTTP FSP SERVER" swap cogcds W!

		_wnfcog dup fspcog W!
		h4 over cogstate andnC!
		hA over cogstate orC!
		c" HTTP FSP" swap cogcds W!

		_wnfcog dup chunkercog W!
		h4 over cogstate andnC!
		hA over cogstate orC!
		c" HTTP CHUNKER" swap cogcds W!
	freedict

	begin
		0 reqstatus W!
		accept				\ get a line from the input and parse the first word
		1 reqstatus W!
		0 >in W!
		parsenw dup
		if
			h2 reqstatus W!
[ifdef http_debug
			http_debug W@
			if
				.concr
			then
			c" httpserver data received:" over _http_debugmsg
]
			c" http" tbuf ccopy
			tbuf cappend
[ifdef http_debug
			c" httpserver VERB:" tbuf _http_debugmsg
]
 			tbuf find				\ calls httpGET httpPOST etc
			if
				h3 reqstatus W!
				execute
			else					\ ignore all other requests
[ifdef http_debug
				c" httpserver invalid request:" 0 _http_debugmsg
]
				drop
				h4 reqstatus W!
				httpabort
			then
[ifdef http_debug
			http_debug W@
			if
				.concr
			then
]
		else						\ empty line ignore
			drop
		then
	0
	until
;

: httpfsp
[ifdef http_debug
	c" httpfsp ENTER:" 0 _http_debugmsg
]
	cogid chunkercog W@ iolink

	." httpchunker~h0D"

	key _fsk _fsk _fsk

	begin
		dup hFFFFFF and h3C3F66 =
		if
			h18 rshift emit
			hA fspcog W@ cogstate orC!
			cogid fspcog W@ iolink

[ifdef http_debug
	http_debug W@ h02 and
	if
		dbglock
		c" ~h0DFSP CODE{~h0D" .concstr
		dbgunlock
	then

]
			key _fsk _fsk _fsk
			begin
				dup hFFFF and h3F3E =
				if
					dup h18 rshift
[ifdef http_debug
	http_debug W@ h02 and
	if
		dup .conemit
	then
]
					emit
					h10 rshift
[ifdef http_debug
	http_debug W@ h02 and
	if
		dup .conemit
	then
]
					emit
					-1

				else
					dup h18 rshift
[ifdef http_debug
	http_debug W@ h02 and
	if
		dup .conemit
	then
]
					emit
					_fsk
					0
				then
			until
			cr cr cr
[ifdef http_debug
	http_debug W@ h02 and
	if
		dbglock
		.concr .concr .concr
		c" ~h0D}FSP CODE~h0D" .concstr
		dbgunlock
	then
]
			cogid iounlink
			key _fsk _fsk _fsk
			0

[ifdef http_debug
	c" httpfsp fspcode end:" 0 _http_debugmsg
]
		else
			dup hFF and hFF =
			if
				dup h18 rshift emit
				dup h10 rshift emit
				h8 rshift emit
				-1
			else
				dup h18 rshift emit _fsk
				0
			then
		then
	until

	hFF emit
	cr
	cr
	cogid iounlink
[ifdef http_debug
	c" httpfsp EXIT:" 0 _http_debugmsg
]
;

\ httpchunker ( -- )
: httpchunker
[ifdef http_debug
	c" httpchunker ENTER:" 0 _http_debugmsg
]
	begin
		0
		pad h80 bounds
		do
			key
			dup hFF =
			if
				drop leave
			else
				i C!
				1+
			then
		loop

		base W@ hex
		over <# #s #> .cstr ." ~h0D~h0A"
		base W!
		dup 0<>
		if
			pad over bounds
			do
				i C@ emit
			loop
			." ~h0D~h0A"
		then
[ifdef http_debug
		http_debug W@ h04 and
		if
			dbglock
			c" ~h0DCHUNKER{~h0D" .concstr
			base W@ hex
			over <# #s #> .concstr c" ~h0D~h0A" .concstr
			base W!
			dup 0<>
			if
				pad over bounds
				do
					i C@ .conemit
				loop
				c" ~h0D~h0A" .concstr
			then
			c" ~h0D}CHUNKER~h0D" .concstr
			dbgunlock
		then
]

		h80 =
		if
			0
		else
			." 0~h0D~h0A~h0D~h0A"
[ifdef http_debug
			http_debug W@ h04 and
			if
				dbglock
				c" ~h0DCHUNKER{~h0D" .concstr
				c" 0~h0D~h0A~h0D~h0A" .concstr
				c" ~h0D}CHUNKER~h0D" .concstr
				dbgunlock
			then
]
			-1
		then
	until
	padbl

[ifdef http_debug
	c" httpchunker EXIT:" 0 _http_debugmsg
]
;

\ _httpstart ( -- url block ) any reqdata is set if there is any data following  ? in the url
: _httpstart
[ifdef http_debug
	c" _http_start ENTER:" 0 _http_debugmsg
]

	0 reqdata C!
	lockdict
	c" __fspcode" ccreate $C_a_dovarw w, forthentry
	freedict

	parsenw dup

	if
[ifdef http_debug
	c" _http_start URL:" over _http_debugmsg
]
		C@++ 1- over C!
		dup
[ifdef http_debug
	c" _http_start 111:" over _http_debugmsg
]

		C@++ bounds
		do
			i C@ h3F =
			if
				i 1- over - over
				C!
				ibound i 1+
				-
				dup reqdata C!
				dup
				if
					reqdata 1+
					i 1+ swap rot
					cmove
				else
					drop
				then
				leave
			then
		loop

		dup _ht_find
	else
		drop 0 0
	then
[ifdef http_debug
	c" _http_start EXIT:" 0 _http_debugmsg
]
;

\ _httpend ( --)
: _httpend
[ifdef http_debug
	c" _http_end ENTER:" 0 _http_debugmsg
]
	-1 h01 h11 h10 cogid ip_SOCKsendmultiplereq drop	\ flush output, flush input, then disconnect
	c" __fspcode" (forget)
	0 reqdata C!
[ifdef http_debug
	c" _http_end EXIT:" 0 _http_debugmsg
]
;

\ httpSEND ( cstr1 cstr2 -- ) cstr1 - contentfilename, cstr2 - headerfilename
: httpSEND
\ (cstr1 headerblock -- )
	_ht_find dup
	if
		swap

		_ht_find dup
		if
			_ht_readblk

			dup _ht_filelen
			base W@ swap decimal . ." ~h0D~h0A~h0D~h0A"
			base W!
			_ht_readblk
		else
			2drop httpabort
		then
	else
		2drop httpabort
	then
;

\ http404 ( -- )
: http404
	c" header404" c" r404.htm" httpSEND
;

\ httpGET ( -- )
: httpGET
[ifdef http_debug
	c" httpGET ENTER:" 0 _http_debugmsg
]
	_httpstart
[ifdef http_debug
	c" httpGET: ( -- url block )" 0 _http_debugmsg
]
	h11 cogid ip_SOCKsendreq drop	\ flush the input, we are not going to consider anything else

	dup
	if
		c" header200htm" numpad ccopy
		swap
		C@++ h3 - + numpad hA + h3 cmove
		numpad _ht_find dup
		if
			_ht_readblk
			numpad hA + C@ h66 =
			if
				cogid fspservercog W@ iolink
				." httpfsp~h0D"
				_ht_readblk
				hFF emit
				cr
				cr
				cogid iounlink

			else
				dup _ht_filelen
				base W@ swap decimal . ." ~h0D~h0A~h0D~h0A"
				base W!
				_ht_readblk
				then
		else
			2drop http404
		then

	else
		2drop http404
	then
	_httpend
[ifdef http_debug
	c" httpGET EXIT:" 0 _http_debugmsg
]
;

\
\ assuming you want to start telnet
\
\
c" onboot" find drop pfa>nfa 1+ c" onb002" C@++ rot swap cmove
\
\ onboot ( n1 -- n1)
: onboot
	onb002
\ do not execute if escape has been hit
	fkey? and fkey? and or h1B <>
	if
		c" $S_ip_numTelnet" find
		if
			1 swap 2+ W!
		then
		startTelnet
		1 ip_SOCKhttp
	then
;


text:
      subroutine cogplot
c******************************************************************************
c     This subroutine creates plots of curves-of-growth
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      include 'Linex.com'
      include 'Mol.com'
      include 'Pstuff.com'
      real*4 gfplot(3000), rwplot(3000)
      real*4 xfour, style(1)
      character*4 ion

c*****dump the data into working arrays
      do i=1,ncurve
         gfplot(i) = gf1(i)
         rwplot(i) = w(i)
      enddo

c*****define the plot boundaries
      ylo = real(nint(rwlow*10))/10. - 0.1
      yhi = real(nint(rwhigh*10))/10. + 0.1
      do i=1,ncurve
         if (rwplot(i) .gt. rwlow) then
            if (gfplot(i) .gt. 0) then
               xlo = real(int(gfplot(i)*10))/10
            else
               xlo = real(int(gfplot(i)*10))/10 - 0.1
            endif
            go to 10
         endif
      enddo
10    do i=1,ncurve
         if (rwplot(i) .gt. rwhigh) then
            if (gfplot(i) .gt. 0) then
               xhi = real(int(gfplot(i)*10))/10 + 0.1
            else
               xhi = real(int(gfplot(i)*10))/10
            endif
         endif
      enddo

c*****start the plot via some setup calls
c      call sm_limits (xlo,xhi,ylo,yhi)
      smlxtic = 0.20
      smlytic = 0.20
      bigxtic = 1.0
      bigytic = 1.0
c      call sm_ticksize (smlxtic,bigxtic,smlytic,bigytic)

c*****draw and label the box for the curve-of-growth
c      call sm_expand (0.6)
c      call sm_lweight (1.4)
      call defcolor (1)
c      call sm_box (0,0,0,0)
c      call sm_expand (0.85)
c      call sm_box (1,2,4,4)
      array = 'log gf'
c      call sm_relocate (0.5*(xlo+xhi),ylo-0.10*(yhi-ylo))
c      call sm_putlabel (5,array)
      array = 'log (EW/lambda)'
c      call sm_relocate (xlo-0.06*(xhi-xlo),0.5*(yhi+ylo))
c      call sm_angle (90.)
c      call sm_putlabel (5,array)
c      call sm_angle (0.)
c      call sm_ltype (1)
c      call sm_lweight (0.8)
c      call sm_grid (0,0)
c      call sm_ltype (0)

c*****plot the computed curve-of-growth points; exit normally
c      call sm_expand (1.05)
      call defcolor (2)
      style(1) = 240.7
c      call sm_ptype (style,1)
c      call sm_points (gfplot,rwplot,ncurve)
      call defcolor (1)
      ich = idint(charge(lim1) + 0.1)
      if (ich .eq. 1) then
         ion = ' I  '
      elseif (ich .eq. 2) then
         ion = ' II '
      elseif (ich .eq. 3) then
         ion = ' III'
      endif
      iatom = idint(atom1(lim1))
      write (array,1002) names(iatom),ion
c      call sm_expand (0.75)
c      call sm_relocate (xhi-0.20*(xhi-xlo),ylo+0.35*(yhi-ylo))
c      call sm_putlabel (5,array)
c      call sm_relocate ((xhi+xlo)/2.0,yhi-0.03*(yhi-ylo))
c      call sm_putlabel (5,moditle)
      xfour = dlog10(xabund(iatom)) + 12.0
      write (array,1003) xfour
c      call sm_relocate (xhi-0.20*(xhi-xlo),ylo+0.27*(yhi-ylo))
c      call sm_putlabel (5,array)
      write (array,1005) wave1(lim1)
c      call sm_relocate (xhi-0.20*(xhi-xlo),ylo+0.19*(yhi-ylo))
c      call sm_putlabel (5,array)
      write (array,1004) e(lim1,1)
c      call sm_relocate (xhi-0.20*(xhi-xlo),ylo+0.11*(yhi-ylo))
c      call sm_putlabel (5,array)
      return

c*****format statements
1002  format (a2,a4)
1003  format ('log eps =',f7.3)
1004  format ('E.P. (eV) =',f7.3)
1005  format ('lambda (A) =',f11.3)

      end

max_stars_repo_name: sselgueta/pymoog

max_issues_repo_name: Jimmy-INL/pymoog

max_forks_repo_name: Jimmy-INL/pymoog


text:
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSA1S (NI,XI,YI,KNOTS,NO,XO,YO,NWRK,WORK,IER)
C
      DIMENSION XI(NI),YI(NI),XO(NO),YO(NO),WORK(NWRK)
C
C  Check on the number of knots.
C

      IF (KNOTS .LT. 4) THEN
        CALL CFAERR (202,' CSA1S - must have at least four knots',38)
        IER = 202
        RETURN
      ENDIF
C
C  Check on the size of the workspace.
C
      IF (NWRK .LT. KNOTS*(KNOTS+3)) THEN
        CALL CFAERR (203,' CSA1S - workspace too small',28)
        IER = 203
        RETURN
      ENDIF
C
C  Call the expanded entry.
C
      WTS = -1.
      SSMTH = 0.
      NDERIV = 0
      CALL CSA1XS (NI,XI,YI,WTS,KNOTS,SSMTH,NDERIV,NO,XO,YO,
     +             NWRK,WORK,IER)
C
      RETURN
      END


text:
program t
  implicit none
! open stmt read/write from scratch w/rewind
  character*18::answer
  integer::a
  integer::k

  open (unit=95, status='scratch')
  do k=1,3
    write (95, '(i2)') k
  end do

  rewind (95)

  do k=1,3
    read (95, '(i2)') a
    print *,a
  enddo

endprogram t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
The Happy Boys are a Music Scene trance/electronica trio, with two of the members having grown up in Davis and are graduates of the Davis Joint Unified School District, Matt Price and Sklyer Jackman.

Their global music video debut is for their song http://www.youtube.com/watch?vDMVhLLesqGs La Dolce Vita.

20070223 12:30:51 nbsp There tunes are groovin! Aqua, venga boy, and captain jack were influences. Only good things comes from that combo Users/StevenDaubert

20120506 06:18:43 nbsp @StevenDaubert Did you know that Matt grew up on our street? Users/TysonNichols

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
 subroutine get_solar_spectrum( &
    nsmax,                 ns_elas,     nwave,      &
    dnu,                   nwave_aux,   wavenr_aux, &
    solar_irradiance_aux)

!-----------------------------------------------------------
! Subroutine:
!   get_solar_spectrum
!
! Purpose:
!   Reads MODTRAN solar spectrum given on 1cm-1 grid and
!   returns this reference solar spectrum on the desired
!   wavenr grid in [photons cm-2 (cm-1)-1 s-1]
!
! Output:
!    solar_irradiance_aux
!    on wavenr_aux grid
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

  integer,intent(in):: &
    nsmax, &
    ns_elas, &
    nwave, &  !wavenr grid
    nwave_aux !extended wavenr grid

  integer:: &
    istat,          &
    l,              &
    n,              &
    nstart,         & !1cm-1 index corresponding to wavenr_aux(1)
    nend,           & !1cm-1 " to wavenr_aux(nwave_aux)
    nwave_1cm,      &
    sun_data_switch

  real(kind=dp):: &
    nu_min,     &
    nu_max,     &
    wavenr_1cm_min, &
    wavenr_1cm_max, &
    a, &
    b, &
    filter_radius, &
    scale_factor

  real(kind=dp),dimension(:),allocatable:: &
    wavenr_1cm, &
    solar_irradiance_1cm

  integer,parameter:: &
    ndata = 49951

  real(kind=dp),intent(in):: &
    dnu,        & !wavenr binwidth [cm-1]
    wavenr_aux(nwave_aux)

  real(kind=dp),intent(out):: &
    solar_irradiance_aux(nwave_aux)

  real(kind=dp)::nu0,dnu0

!---------------------------------------------------------
! Read extraterrestrial solar irradiance [W cm-2 cm]
! on 1cm-1 wavenr grid
!
! sun_data_switch = 1 chkur     Chance & Spurr
!                 = 2 newkur    Kurucz
!                 = 3 cebchkur
!                 = 4 thkur
!                 = 5 vandeelen2005, Eq.(20), for testing
!                 = 6 constant, for testing
!---------------------------------------------------------

  sun_data_switch = 1 !chkur
! sun_data_switch = 6

! wavenr range of input
  nu_min =    50.d0 !cm-1 = wavelength 200000 nm
  nu_max = 50000.d0 !cm-1 = wavelength 200 nm

! filter radius of resample function
  filter_radius = 2.d0

! wavenr range of 1 cm-1 spectrum
  wavenr_1cm_min = wavenr_aux(1)         - filter_radius*dnu
  wavenr_1cm_max = wavenr_aux(nwave_aux) + filter_radius*dnu

  if(wavenr_1cm_min.lt.nu_min) &
    write(*,*) 'ietsun.f90: Uhoh... outside 1cm-1 wavenr range'
  if(wavenr_1cm_max.gt.nu_max) &
    write(*,*) 'getsun.f90: Uhoh... outside 1cm-1 wavenr range'

! read solar irradiance spectrum from file
! on 1cm-1 wavenr grid

  nwave_1cm = int(wavenr_1cm_max-wavenr_1cm_min)+2

  allocate( &
    wavenr_1cm(nwave_1cm),          &
    solar_irradiance_1cm(nwave_1cm), &
    stat=istat)

!-------------------------------------------------------------
! Read one of MODTRAN solar spectra
!-------------------------------------------------------------

  if(sun_data_switch.eq.1) &
     open(1,file='../data/chkur.dat',status='old')
  if(sun_data_switch.eq.2) &
     open(1,file='../data/newkur.dat',status='old')
  if(sun_data_switch.eq.3) &
     open(1,file='../data/cebchkur.dat',status='old')
  if(sun_data_switch.eq.4) &
     open(1,file='../data/thkur.dat',status='old')
  if((sun_data_switch.eq.5).or.(sun_data_switch.eq.6))then
     open(1,file='../data/thkur.dat',status='old') !dummy
  endif

  read(1,*)
  read(1,*)

  n=1
  do l=1,ndata
     read(1,*) a,b
     if(a.ge.wavenr_1cm_min)then
         wavenr_1cm(n)           = a
         solar_irradiance_1cm(n) = b
         if(abs(wavenr_1cm(n)-wavenr_aux(1)).lt.1.d-4) nstart=n
         if(abs(wavenr_1cm(n)-wavenr_aux(nwave_aux)).lt.1.d-4) nend=n
         n=n+1
         if(n.gt.nwave_1cm) goto 11
     endif
   enddo
11 continue

  close(1)

!--------------------------------------------------------------
! Artificial solar spectrum for testing purposes
! with one solar Fraunhofer line
!-------------------------------------------------------------

  if(sun_data_switch.eq.5)then

     nu0  = 25414.d0 !cm-1
     dnu0 = 70.d0 !cm-1

     do n=1,nwave_1cm
        if(abs(wavenr_1cm(n)-nu0).lt.dnu0)then
            solar_irradiance_1cm(n) = 1000.d0*(1.d0 - &
               0.82d0*(1.d0-abs(wavenr_1cm(n)-nu0)/dnu0))
        else
            solar_irradiance_1cm(n) = 1000.d0 * 1.d0
        endif
     enddo

!    open(10,file='../output/spectrum_1cm.dat',status='unknown')
!    write(10,'(a21)') '# spectrum 1cm-1 grid'
!    write(10,'(a8,a12)') '# w [nm]','F [ ]'
!    do n=nwave_1cm,1,-1
!       write(10,'(f8.4,f12.4)') &
!        1.d7/wavenr_1cm(n),solar_irradiance_1cm(n)
!    enddo
!    close(10)

  endif

!--------------------------------------------------------------
! Artificial solar continuum for testing purposes
!-------------------------------------------------------------

  if(sun_data_switch.eq.6)then

     do n=1,nwave_1cm
        solar_irradiance_1cm(n) = 1000.d0
     enddo

  endif

!----------------------------------------------------------
! Resample solar spectrum on 1cm-1 grid to solar spectrum
! on wavenr_aux grid
!----------------------------------------------------------

! 1 cm-1 binwidth / dnu binwidth [cm-1]
  scale_factor = 1.d0/dnu

  call resample( &
       nsmax,          ns_elas,      dnu,                  &
       filter_radius,  nstart,       nend,                 &
       nwave_1cm,      wavenr_1cm,   solar_irradiance_1cm, &
       nwave_aux,      wavenr_aux,   solar_irradiance_aux)

!----------------------------------------------------------
! Test
!----------------------------------------------------------
! do n=1,nwave_aux
!    solar_irradiance_aux(n) = 1.d0
!    if(n.le.nsmax)         solar_irradiance_aux(n) = 0.d0
!    if(n.ge.nsmax+nwave+1) solar_irradiance_aux(n) = 0.d0
! enddo
!----------------------------------------------------------

  deallocate( &
    wavenr_1cm,            &
    solar_irradiance_1cm)

  return
  end subroutine get_solar_spectrum

max_stars_repo_name: rutgervandeelen/das

max_issues_repo_name: rutgervandeelen/das

max_forks_repo_name: rutgervandeelen/das