text:
      PROGRAM xchebev
C     driver for routine chebev
      INTEGER NVAL
      REAL PIO2
      PARAMETER(NVAL=40, PIO2=1.5707963)
      INTEGER i,mval
      REAL a,b,chebev,func,x,c(NVAL)
      EXTERNAL func
      a=-PIO2
      b=PIO2
      call chebft(a,b,c,NVAL,func)
C     test Chebyshev evaluation routine
10    write(*,*) 'How many terms in Chebyshev evaluation?'
      write(*,'(1x,a,i2,a)') 'Enter n between 6 and ',NVAL,
     *     '. Enter n=0 to END.'
      read(*,*) mval
      if ((mval.le.0).or.(mval.gt.NVAL)) goto 20
      write(*,'(1x,t10,a,t19,a,t28,a)') 'X','Actual','Chebyshev fit'
      do 11 i=-8,8,1
        x=i*PIO2/10.0
        write(*,'(1x,3f12.6)') x,func(x),chebev(a,b,c,mval,x)
11    continue
      goto 10
20    END
      REAL FUNCTION func(x)
      REAL x
      func=(x**2)*(x**2-2.0)*sin(x)
      END

ext: for

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


text:
Want to search Davis Wiki right from your browser?  There are a few options for you depending on the browser you use.

Firefox

Search Plugin

Have http://www.mozilla.org/products/firefox/ Firefox or http://www.mozilla.org/products/mozilla1.x/ Mozilla?
 Then you should firefoxsearch Image(screenshotexample.jpg, From Yahoo to Wiki!, right, thumbnail)

The plugin installs a little search bar to the side of the URL bar, allowing you to search and access the Wiki from any page. The search bar can be accessed by the mouse, CtrlK, or tab from the address bar. Search plugins can be selected using Ctrlup and Ctrldown or the mouse.

Want to search the UC Davis website in a similar fashion?
 Simply ucdavissearch

The Atmospheric Science Department has also released a search plugin for finding people in the UCD Directory, http://atm.ucdavis.edu/tools/UCDPeople.php available here.

Theres a toolbar available for download at http://www.davisol.com/toolbar, you will be able to search Davis Wiki, UC Davis Pages and UC Davis People from any page with either IE or Firefox/Mozilla

Manual Setup

If you dont want to install anything in your browser, Firefox will also allow you to set up a simple keyword for searching the DavisWiki using just your browsers location bar.  To do so, (1) just rightclick on the search box at the top of any DavisWiki page.  Then, (2) select Add a Keyword for this Search....  Then, (3) name the search DavisWiki (or whatever you want), choose a keyword (e.g. dwiki), and click Add.  Done.  Now you can search the DavisWiki using the location bar on your browser.  Just type your keyword (like dwiki), a space, and the terms you want to search for.

BookmarkletStyle Alternative

This is the wiki:Wikipedia:Bookmarklet that Users/EBT wrote and currently uses:

{{{
javascript:(function(){if(x%s){location.hrefhttp://daviswiki.org/?actionsearch&inline_string+escape(x)}else{location.hrefhttp://daviswiki.org/Recent_Changes}})();
}}}

Instructions:
 1. Create a new bookmark.
 2. Replace target URL with wiki:Wikipedia:JavaScript JavaScript code above.
 3. Give it a keyword, similar to the manual setup above. (recommended: dw)
 4. Now dw shark will search the wiki for sharks, and just dw will take you to Recent Changes!
 5. Enjoy your new life as a wiki:C2:RecentChangesJunkie recent changes junkie.

Google

This trick works in any browser.  You can simply put site:daviswiki.org in your search.  So to find all results for Best Pizza, type the following into Google:

{{{
best pizza site:daviswiki.org
}}}

...and youll find every place on the wiki referring to the best pizza in Davis.

Konqueror

Konqueror Web Shortcut for the Wiki Search: {{{
http://daviswiki.org/FrontPage?text_new\{@}&actioninlinesearch&button_new.x0&context40
}}}

Konqueror Web Shortcut for the Wiki: {{{
http://daviswiki.org/\{@}
}}}

Go to Settings, Configure Konqueror, Web Shortcuts and paste the above line and pick a shortcut.  I use dw.  Then you can use URLs like dw:Pizza to either jump directly to an entry or to search for the term.

Already have a plugin installed? Like it, love it, hate it? Leave some feedback!

20050708 18:55:32 nbsp Works great, any chance that a ucdavis.edu version could be written? Users/MarkWetter

20050708 19:59:18 nbsp Here you go, hope you find it useful.  I dont think it deserves its own page or anything, is this an ok spot to keep it? Users/MikeIvanov

20050709 01:56:12 nbsp VERY MUCH appreciated. I tried to write my own, but the extra radio buttons scared me too much to try. Users/MarkWetter

20050709 02:33:07 nbsp No problem, theyre very easy to make.  This one just does the pages search. Users/MikeIvanov

20050725 20:43:16 nbsp Grr. I just started hacking one together for RocWiki, and I check here, and it already exists. Curse you, and that little dog of yours too! Users/FarMcKon

20070302 13:17:13 nbsp I cant get the atmospheric sciences UCD Directory search to work. Users/JamesHaile

20070302 13:29:27 nbsp tight.  Thisll be handy know that Im using the wiki more. Users/BradBenedict

20070302 14:28:29 nbsp I love this thing... Users/CarlosOverstreet

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!==============================================================================!
  subroutine Control_Mod_Heat_Capacity(val, verbose)
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real              :: val
  logical, optional :: verbose
!==============================================================================!

  call Control_Mod_Read_Real_Item('HEAT_CAPACITY', 1.0, val, verbose)

  end subroutine

max_issues_repo_name: EdinSmartLab/T-Flows

max_forks_repo_name: EdinSmartLab/T-Flows


text:
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! Test use-associated (same variable and function names)from two modules n and
! m.

module m
  integer, parameter :: i = -1
  interface
    module subroutine show_i
    end subroutine show_i
  end interface
contains
  integer function times_two (arg)
    integer :: arg
    times_two = -2*arg
  end function
end module m

module n
  integer, parameter :: i = 2
contains
  integer function times_two (arg)
    integer :: arg
    times_two = 2*arg
  end function
end module n

submodule (m) sm
  use n
contains
  module subroutine show_i
    if (i .ne. 2) then
      print *, "FAIL"
    else
      print *, "PASS"
    endif
    if (times_two (i) .ne. 4) then
      print *, "FAIL"
    else
      print *, "PASS"
    endif
  end subroutine show_i
end submodule sm

program p
  use m
  call show_i
  if (i .ne. -1) then
    print *, "FAIL"
  else
    print *, "PASS"
  endif
  if (times_two (i) .ne. 2) then
    print *, "FAIL"
  else
    print *, "PASS"
  endif
end program

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
   Module CCScr

   Use Precision
   Implicit None
   Real (Kind=pr), Allocatable :: G2aaaa(:,:,:)
   Real (Kind=pr), Allocatable :: G2abab(:,:,:)
   Real (Kind=pr), Allocatable :: G2abba(:,:,:)
   Real (Kind=pr), Allocatable :: Joo(:), Jvv(:)

   Contains

      Subroutine SetUpCCScr(O,V,N)
      Implicit None
      Integer, Intent(In) :: O, V, N
      Integer :: IAlloc
      Allocate(G2aaaa(1:O,1:O,V:N),     &
               G2abab(1:O,1:O,V:N),     &
               G2abba(1:O,1:O,V:N),     &
               Joo(1:O), Jvv(V:N),      &
               Stat=IAlloc)
      If(IAlloc /= 0) Stop 'Could not allocate in CCScr'
      Return
      End Subroutine SetUpCCScr

      Subroutine ShutDownCCScr
      Implicit None
      Integer :: IAlloc
      DeAllocate(G2aaaa, G2abab, G2abba, Joo, Jvv, Stat=IAlloc)
      If(IAlloc /= 0) Stop 'Could not deallocate in CCScr'
      Return
      End Subroutine ShutDownCCScr

   End Module CCScr

max_stars_repo_name: jamesjshepherd/uegccd

max_issues_repo_name: shepherd-group/uegccd-dev

max_forks_repo_name: shepherd-group/uegccd-dev


text:
module da_tools_serial

   !---------------------------------------------------------------------------
   ! Purpose: Contains serial tools, useable by gen_be which doesn't like parallel
   !---------------------------------------------------------------------------

   use da_control, only : unit_used, unit_end, unit_start, stdout, num_fft_factors, pi
   use da_reporting, only : da_error

   implicit none

contains

#include "da_get_unit.inc"
#include "da_free_unit.inc"
#include "da_change_date.inc"
#include "da_array_print.inc"
#include "da_advance_cymdh.inc"
#include "da_advance_time.inc"
#include "da_find_fft_factors.inc"
#include "da_find_fft_trig_funcs.inc"

end module da_tools_serial

max_stars_repo_name: matzegoebel/WRF-fluxavg

max_issues_repo_name: teb-model/wrf-teb

max_forks_repo_name: teb-model/wrf-teb


text:
* Eigen2x2.f
* diagonalization of a Hermitian 2-by-2 matrix
* this file is part of FormCalc
* last modified 15 Jun 04 th

	subroutine Eigen2x2(m, msq, U, M11, M22, M12, *)
	implicit none
	double precision m(*), msq(*)
	double complex U(2,*)
	double precision M11, M22
	double complex M12

	double precision m1, m2, delta, tau
	double complex s

	call Jacobi(delta, s, tau, M11 - M22, M12, abs(M12))

	m1 = M11 + delta
	m2 = M22 - delta

	if( m1 .gt. m2 ) then
	  msq(1) = m2
	  msq(2) = m1
	  U(1,1) = -dconjg(s)
	  U(2,2) = s
	  U(1,2) = 1 - tau
	  U(2,1) = U(1,2)
	else
	  msq(1) = m1
	  msq(2) = m2
	  U(1,1) = 1 - tau
	  U(2,2) = U(1,1)
	  U(1,2) = s
	  U(2,1) = -dconjg(s)
	endif

	if( msq(1) .lt. 0 ) then
	  print *, "Negative mass-squares."
	  return 1
	endif
	m(1) = sqrt(msq(1))
	m(2) = sqrt(msq(2))
	end


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License along
! with this program; if not, write to the Free Software Foundation, Inc.,
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  subroutine setup_GLL_points()

! computes shape functions and their derivatives for SEM grid

  use specfem_par

  implicit none

  ! local parameters
  integer :: i,j,ier

  ! set up Gauss-Lobatto-Legendre points, weights and also derivation matrices (hprime_**,..)
  call define_derivation_matrices()

  if (AXISYM) then
    ! set up Gauss-Lobatto-Jacobi points, weights and also derivation matrices
    call define_GLJ_derivation_matrix()
  endif

  ! shape arrays
  allocate(shape2D(ngnod,NGLLX,NGLLZ), &
           dershape2D(NDIM,ngnod,NGLLX,NGLLZ),stat=ier)
  if (ier /= 0) stop 'Error allocating shape arrays'

  do j = 1,NGLLZ
    do i = 1,NGLLX
      call define_shape_functions(shape2D(:,i,j),dershape2D(:,:,i,j),xigll(i),zigll(j),ngnod)
    enddo
  enddo

  ! allocate 1-D Lagrange interpolators and derivatives
  ! for source and receivers
  allocate(hxir(NGLLX), &
           hxis(NGLLX), &
           hpxir(NGLLX), &
           hpxis(NGLLX), &
           hgammar(NGLLZ), &
           hgammas(NGLLZ), &
           hpgammar(NGLLZ), &
           hpgammas(NGLLZ),stat=ier)
  if (ier /= 0) stop 'error allocating arrays for interpolators'

  end subroutine setup_GLL_points


program nca_hm_square
  USE DMFT_NCA
  USE SCIFOR
  USE DMFT_TOOLS
  implicit none
  integer                                     :: iloop,Lk,Nso
  logical                                     :: converged
  !The local hybridization function:
  complex(8),allocatable,dimension(:,:,:,:,:) :: Delta
  complex(8),allocatable,dimension(:,:,:,:,:) :: Smats
  complex(8),allocatable,dimension(:,:,:,:,:) :: Gmats

  !hamiltonian input:
  complex(8),allocatable,dimension(:,:,:)     :: Hk
  complex(8),allocatable,dimension(:,:)       :: modelHloc
  complex(8),allocatable,dimension(:,:,:,:)   :: Hloc
  real(8),allocatable,dimension(:)            :: Wtk

  !variables for the model:
  integer                                     :: Nk,Nkpath
  real(8)                                     :: ts,wmixing
  character(len=32)                           :: finput
  character(len=32)                           :: hkfile
  logical :: bool
  !

  !Parse additional variables && read Input && read H(k)^2x2
  call parse_cmd_variable(finput,"FINPUT",default='inputED.conf')
  call parse_input_variable(hkfile,"HKFILE",finput,default="hkfile.in")
  call parse_input_variable(nk,"NK",finput,default=100)
  call parse_input_variable(nkpath,"NKPATH",finput,default=500)
  call parse_input_variable(ts,"TS","inputED.conf",default=0.25d0)
  call parse_input_variable(wmixing,"WMIXING",finput,default=0.5d0)
  !
  call nca_read_input(trim(finput))

  call add_ctrl_var(Norb,"Norb")
  call add_ctrl_var(Nspin,"Nspin")
  call add_ctrl_var(beta,"BETA")
  call add_ctrl_var(xmu,"xmu")
  !
  if(Norb/=1)stop "Wrong setup from input file: Norb=1"
  Nso=Nspin*Norb

  !Allocate Weiss Field:
  allocate(Delta(Nspin,Nspin,Norb,Norb,Lmats));Delta=zero
  allocate(Smats(Nspin,Nspin,Norb,Norb,Lmats));Smats=zero
  allocate(Gmats(Nspin,Nspin,Norb,Norb,Lmats));Gmats=zero
  allocate(Hloc(Nspin,Nspin,Norb,Norb));Hloc=zero

  !Build the Hamiltonian on a grid or on a path
  call build_hk(trim(hkfile))
  Hloc = so2nn_reshape(modelHloc,Nspin,Norb)

  call dmft_gloc_matsubara(Hk,Wtk,Gmats,Smats,iprint=1)
  call dmft_delta(Gmats,Smats,Delta,Hloc,iprint=1)

  !Setup solver
  call nca_init_solver(Hloc)

  !DMFT loop
  iloop=0;converged=.false.
  do while(.not.converged.AND.iloop<nloop)
     iloop=iloop+1
     call start_loop(iloop,nloop,"DMFT-loop")

     call nca_solve(Delta)

     Smats = impSmats

     ! compute the local gf:
     call dmft_gloc_matsubara(Hk,Wtk,Gmats,Smats,iprint=1)

     call dmft_delta(Gmats,Smats,Delta,Hloc,iprint=1)

     converged = check_convergence(Delta(1,1,1,1,:),dmft_error,nsuccess,nloop)

     call end_loop
  enddo

  ! call dmft_kinetic_energy(Hk,Wtk,Smats)

contains

  !--------------------------------------------------------------------!
  !Lattice Hamitonian:
  !--------------------------------------------------------------------!
  function hk_model(kpoint,N) result(hk)
    real(8),dimension(:)      :: kpoint
    integer                   :: N,i
    complex(8),dimension(N,N) :: hk
    real(8)                   :: kx,ky
    !
    if(N/=Nso)stop "hk_model: N != Nso"
    !
    kx=kpoint(1)
    ky=kpoint(2)
    !
    hk(:,:) = zero
    !
    hk = -2d0*ts*(cos(kx)+cos(ky))*eye(N)
    !
  end function hk_model

  !---------------------------------------------------------------------
  !PURPOSE: get model Hamiltonian
  !---------------------------------------------------------------------
  subroutine build_hk(file)
    character(len=*),optional             :: file
    integer                               :: i,j,ik
    integer                               :: ix,iy
    real(8)                               :: kx,ky
    integer                               :: iorb,jorb
    integer                               :: isporb,jsporb
    integer                               :: ispin,jspin
    integer                               :: unit
    real(8),dimension(2)                  :: kvec
    real(8)                               :: blen,area_hex,area_rect,points_in,points_tot
    real(8),allocatable,dimension(:)      :: kxgrid,kygrid
    real(8),dimension(:,:),allocatable    :: kpath

    Lk= Nk*Nk

    write(LOGfile,*)"Build H(k)    :",Lk
    write(LOGfile,*)"# of SO-bands :",Nso

    if(allocated(Hk))deallocate(Hk)
    if(allocated(wtk))deallocate(wtk)
    allocate(Hk(Nso,Nso,Lk));Hk=zero
    allocate(wtk(Lk));Wtk=0d0

    call TB_set_bk([pi2,0d0],[0d0,pi2])

    call TB_build_model(Hk, hk_model, Nso, [Nk,Nk])

    Wtk = 1d0/Lk

    if(present(file))&
         call TB_write_hk(Hk, trim(file), &
         No = Nso,Nd = Norb,Np = 0,Nineq = 1,&
         Nkvec=[Nk,Nk])
    !
    allocate(modelHloc(Nso,Nso))
    modelHloc = sum(Hk(:,:,:),dim=3)/Lk
    where(abs((modelHloc))<1.d-4)modelHloc=zero

    !path: G X M G
    allocate(kpath(4,2))
    kpath(1,:)=[0d0,0d0]
    kpath(2,:)=[ pi,0d0]
    kpath(3,:)=[ pi, pi]
    kpath(4,:)=[0d0,0d0]
    call TB_solve_model(hk_model,Nso,kpath,Nkpath,&
         colors_name=[red1],&
         points_name=[character(len=10) :: "G","X","M", "G"],&
         file="Eigenbands.nint")
  end subroutine build_hk

end program nca_hm_square


! PR fortran/49540
! { dg-do compile }
! { dg-options "" }
block data
  common /a/ i(5,5)
  data i /4, 23 * 5, 6/
  data i(:,2) /1, 3 * 2, 3/
  common /b/ j(5,5)
  data j(2,:) /1, 3 * 2, 3/
  data j /4, 23 * 5, 6/
  common /c/ k(5,5)
  data k(:,2) /1, 3 * 2, 3/
  data k /4, 23 * 5, 6/
  common /d/ l(5,5)
  data l /4, 23 * 5, 6/
  data l(2,:) /1, 3 * 2, 3/
end block data


text:
xPress was a shortlived alternative newspapers newspaper published and distributed between 1993 and 1994 under the auspices of AS PAPERS. Created by editor Jubal ________, xPress released just two issues. Its original issue included an early profile of Davis band Shove and future indie songstress Jen Schande.

After months of delays, a second and final issue of xPress appeared on newsstands in the student union. This also marked a second incarnation of xPress, rebooted from a campus music scene music zine to a new format, its designs heavily influenced by militant Communism and its content striking a tone similar to that of Rage Against The Machine albums. xPress then ceased publication.


text:
Due to ongoing intimidation and legal threats toward other contributors, Phil Allen has been BannedGroup banned from editing this wiki

Now engaging in email harassment, be warned...
Phil has not gone away and as of this date (11/8/11) has still harassed his competitors, I received an email again how he claims he has people spying and taping conversations at competitors place of business. It may not mean that much to you guys, all of these people are my friends. Im considering posting comments on COFP and theyre not going to be very favorable, however they will be the truth, Id like a quick input on banning both of their pages (Woodland/Davis). Its the right thing to do. It will end in court someday, but for now their business should not be rewarded for this ongoing behavior. Users/Theangrydiner
  This has been discussed already, to death.  First, the business isnt PAs, its his wifes.  Second, having a page for the business on the wiki is not a reward (or a punishment either).  It is information for the people of Davis and Woodland.  Ive never heard of a page being banned.  cp
  AngryDinerthe Wiki shouldnt be used to air dirty laundry like that.  Phil was banned for his actions ON THE WIKIwhat you are referring to has nothing to do with the Wiki and is best taken up ONLY in court (or private mediator if hed be willing). Please do it somewhere else...and I dont ever see the pages being banned.Users/PeterBoulay


text:
C$Procedure ZZEKLLTI ( EK, last less than, integer )

      SUBROUTINE ZZEKLLTI (  HANDLE,  SEGDSC,  COLDSC,
     .                       IKEY,    PRVLOC,  PRVPTR  )

C$ Abstract
C
C     Find the last column value less than a specified key,
C     for a specified, indexed integer EK column.
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     EK
C
C$ Keywords
C
C     EK
C     PRIVATE
C
C$ Declarations

      INCLUDE 'ekbool.inc'
      INCLUDE 'ekcnamsz.inc'
      INCLUDE 'ekcoldsc.inc'
      INCLUDE 'ekopcd.inc'
      INCLUDE 'eksegdsc.inc'
      INCLUDE 'ektype.inc'

      INTEGER               HANDLE
      INTEGER               SEGDSC ( SDSCSZ )
      INTEGER               COLDSC ( CDSCSZ )
      INTEGER               IKEY
      INTEGER               PRVLOC
      INTEGER               PRVPTR

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     SEGDSC     I   Segment descriptor.
C     COLDSC     I   Column descriptor.
C     IKEY       I   Integer key.
C     PRVLOC     O   Ordinal position of predecessor of IKEY.
C     PRVPTR     O   Pointer to record containing predecessor of IKEY.
C
C$ Detailed_Input
C
C     HANDLE         is an EK file handle.  The file may be open for
C                    reading or writing.
C
C     SEGDSC         is the segment descriptor of the segment
C                    containing the column specified by COLDSC.
C
C     COLDSC         is the column descriptor of the column to be
C                    searched.
C
C     IKEY           is an integer key.  The last column entry
C                    less than this key is sought.
C
C$ Detailed_Output
C
C     PRVLOC         is the ordinal position, according to the order
C                    relation implied by the column's index, of the
C                    record containing the last element less than IKEY.
C
C                    If all elements of the column are greater than
C                    or equal to IKEY, PRVLOC is set to zero.
C
C     PRVPTR         is a pointer to the record containing the element
C                    whose ordinal position is PRVLOC.
C
C                    If all elements of the column are greater than
C                    or equal to IKEY, PRVPTR is set to zero.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If HANDLE is invalid, the error will be diagnosed by routines
C         called by this routine.
C
C     2)  If the data type of the input column is not character,
C         the error SPICE(INVALIDTYPE) is signalled.
C
C     3)  If the input column is not indexed, the error
C         SPICE(NOTINDEXED) is signalled.
C
C     4)  If the index type of the input column is not recognized,
C         the error will be diagnosed by routines called by this
C         routine.
C
C     5)  If an I/O error occurs while reading or writing the indicated
C         file, the error will be diagnosed by routines called by this
C         routine.
C
C$ Files
C
C     See the EK Required Reading for a discussion of the EK file
C     format.
C
C$ Particulars
C
C     This routine finds the last column element less than a specified
C     integer key, within a specified segment and column.
C
C     In order to support the capability of creating an index for a
C     column that has already been populated with data, this routine
C     does not require that number of elements referenced by the
C     input column's index match the number of elements in the column;
C     the index is allowed to reference fewer elements.  However,
C     every record referenced by the index must be populated with data.
C
C$ Examples
C
C     See ZZEKILLT.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 09-NOV-1995 (NJB)
C
C-&

C
C     Non-SPICELIB functions
C
      LOGICAL               ZZEKSCMP

C
C     Local variables
C
      CHARACTER*(CNAMSZ)    COLUMN

      INTEGER               BEGIN
      INTEGER               BEGPTR
      INTEGER               DTYPE
      INTEGER               END
      INTEGER               ENDPTR
      INTEGER               MIDDLE
      INTEGER               MIDPTR
      INTEGER               NROWS

      LOGICAL               INDEXD

C
C     Use discovery check-in.
C
C     If the column's not indexed, we have no business being here.
C
      INDEXD  =  COLDSC(IXTIDX) .NE. IFALSE

      IF ( .NOT. INDEXD ) THEN

         CALL ZZEKCNAM ( HANDLE, COLDSC, COLUMN )

         CALL CHKIN  ( 'ZZEKLLTI'                 )
         CALL SETMSG ( 'Column # is not indexed.' )
         CALL ERRCH  ( '#',  COLUMN               )
         CALL SIGERR ( 'SPICE(NOTINDEXED)'        )
         CALL CHKOUT ( 'ZZEKLLTI'                 )
         RETURN

      END IF

C
C     Check the column's data type.
C
      DTYPE  =  COLDSC(TYPIDX)

      IF ( DTYPE .NE. INT ) THEN

         CALL ZZEKCNAM ( HANDLE, COLDSC, COLUMN )

         CALL CHKIN  ( 'ZZEKLLTI'                               )
         CALL SETMSG ( 'Column # should be INT but has type #.' )
         CALL ERRCH  ( '#',  COLUMN                             )
         CALL ERRINT ( '#',  DTYPE                              )
         CALL SIGERR ( 'SPICE(INVALIDTYPE)'                     )
         CALL CHKOUT ( 'ZZEKLLTI'                               )
         RETURN

      END IF

C
C     Handle the case of an empty segment gracefully.
C
      NROWS  =  SEGDSC(NRIDX)

      IF ( NROWS .EQ. 0 ) THEN

         PRVLOC = 0
         PRVPTR = 0

         RETURN

      END IF

C
C     The algorithm used here is very like unto that used in LSTLTD.
C
      BEGIN   =   1
      END     =   NROWS

C
C     Get the record pointers BEGPTR and ENDPTR of the least and
C     greatest elements in the column.
C
      CALL ZZEKIXLK ( HANDLE, COLDSC, BEGIN, BEGPTR )
      CALL ZZEKIXLK ( HANDLE, COLDSC, END,   ENDPTR )

      IF  (  ZZEKSCMP ( GE,      HANDLE,  SEGDSC,
     .                  COLDSC,  BEGPTR,  1,       INT,
     .                  ' ',     0.0D0,   IKEY,   .FALSE. )  ) THEN
C
C        The smallest entry of the column is greater than or equal to
C        the input value of the same data type, so none of the entries
C        are less than the input value.
C
         PRVLOC = 0
         PRVPTR = 0

      ELSE IF (  ZZEKSCMP ( LT,      HANDLE,  SEGDSC,
     .                      COLDSC,  ENDPTR,  1,      INT,
     .                      ' ',     0.0D0,   IKEY,  .FALSE. )  ) THEN
C
C        The last element of the array is less than the input value of
C        the same data type, so it's the last item less than the input
C        value.
C
         PRVLOC = NROWS

         CALL ZZEKIXLK ( HANDLE, COLDSC, PRVLOC, PRVPTR )

      ELSE
C
C        The input value lies between some pair of column entries.
C        The value is greater than the smallest column entry and
C        less than or equal to the greatest entry.
C
         DO WHILE ( END .GT. BEGIN+1 )
C
C           Find the address of the element whose ordinal position
C           is halfway between BEGIN and END.
C
            MIDDLE   =  ( BEGIN  + END )  / 2

            CALL ZZEKIXLK ( HANDLE, COLDSC, MIDDLE, MIDPTR )

            IF (  ZZEKSCMP ( LT,      HANDLE,  SEGDSC,
     .                       COLDSC,  MIDPTR,  1,       INT,
     .                       ' ',     0.0D0,   IKEY,   .FALSE. )  ) THEN
C
C              The middle value is less than the input value of the
C              same data type.
C
               BEGIN = MIDDLE
            ELSE
               END   = MIDDLE
            END IF
C
C           The input value is greater than the element having ordinal
C           position BEGIN and less than or equal to the element having
C           ordinal position END.
C
         END DO

         PRVLOC = BEGIN
         CALL ZZEKIXLK ( HANDLE, COLDSC, PRVLOC, PRVPTR )

      END IF

      RETURN
      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
      subroutine jiogox(fi,fo,gc,vmass,vwidth , jio)
c
c This subroutine computes an off-shell vector current from an external
c fermion pair.  The vector boson propagator is given in Feynman gauge
c for a massless vector and in unitary gauge for a massive vector in the
c case when they are all color octets.
c
c input:
c       complex fi(6)          : flow-in  fermion                   |fi>
c       complex fo(6)          : flow-out fermion                   <fo|
c       complex gc(2)          : coupling constants                  gvf
c       real    vmass          : mass  of OUTPUT vector v
c       real    vwidth         : width of OUTPUT vector v
c
c output:
c       complex jio(6)         : vector current          j^mu(<fo|v|fi>)
c
      implicit none
      double complex fi(6),fo(6),gc(2),jio(6),c0,c1,c2,c3,cs,d
      double precision q(0:3),vmass,vwidth,q2,vm2
      double complex cm2 ! mass**2- I Gamma mass (Fabio)

      double precision rZero, rOne
      parameter( rZero = 0.0d0, rOne = 1.0d0 )
      double complex cImag, cZero
      parameter( cImag = ( 0.0d0, 1.0d0 ), cZero = ( 0.0d0, 0.0d0 ) )

      jio(5) = fo(5)-fi(5)
      jio(6) = fo(6)-fi(6)

      q(0) = dble( jio(5))
      q(1) = dble( jio(6))
      q(2) = dimag(jio(6))
      q(3) = dimag(jio(5))
      q2 = q(0)**2-(q(1)**2+q(2)**2+q(3)**2)
      vm2 = vmass**2

      if ( vmass.ne.rZero ) then

         d = rOne/dcmplx( q2-vm2, vmass*vwidth )
c     For the running width, use below instead of the above d.
c     d = rOne/dcmplx( q2-vm2, max(vwidth*q2/vmass,rZero) )

         if ( gc(2).ne.cZero ) then
            c0 =  gc(1)*( fo(3)*fi(1)+fo(4)*fi(2))
     &           +gc(2)*( fo(1)*fi(3)+fo(2)*fi(4))
            c1 = -gc(1)*( fo(3)*fi(2)+fo(4)*fi(1))
     &           +gc(2)*( fo(1)*fi(4)+fo(2)*fi(3))
            c2 =( gc(1)*( fo(3)*fi(2)-fo(4)*fi(1))
     &           +gc(2)*(-fo(1)*fi(4)+fo(2)*fi(3)))*cImag
            c3 =  gc(1)*(-fo(3)*fi(1)+fo(4)*fi(2))
     &           +gc(2)*( fo(1)*fi(3)-fo(2)*fi(4))
         else
            d = d*gc(1)
            c0 =   fo(3)*fi(1)+fo(4)*fi(2)
            c1 =  -fo(3)*fi(2)-fo(4)*fi(1)
            c2 = ( fo(3)*fi(2)-fo(4)*fi(1))*cImag
            c3 =  -fo(3)*fi(1)+fo(4)*fi(2)
         end if

c     Fabio's implementation of the fixed width
         cm2=dcmplx( vm2, -vmass*vwidth )
c     cs = (q(0)*c0-q(1)*c1-q(2)*c2-q(3)*c3)/vm2
         cs = (q(0)*c0-q(1)*c1-q(2)*c2-q(3)*c3)/cm2
         jio(1) = (c0-cs*q(0))*d
         jio(2) = (c1-cs*q(1))*d
         jio(3) = (c2-cs*q(2))*d
         jio(4) = (c3-cs*q(3))*d

      else

         d = dcmplx( rOne/q2, rZero )
         if ( gc(2).ne.cZero ) then
            jio(1) = ( gc(1)*( fo(3)*fi(1)+fo(4)*fi(2))
     &                +gc(2)*( fo(1)*fi(3)+fo(2)*fi(4)) )*d
            jio(2) = (-gc(1)*( fo(3)*fi(2)+fo(4)*fi(1))
     &                +gc(2)*( fo(1)*fi(4)+fo(2)*fi(3)) )*d
            jio(3) = ( gc(1)*( fo(3)*fi(2)-fo(4)*fi(1))
     &                +gc(2)*(-fo(1)*fi(4)+fo(2)*fi(3)))
     &               *d*cImag
            jio(4) = ( gc(1)*(-fo(3)*fi(1)+fo(4)*fi(2))
     &                +gc(2)*( fo(1)*fi(3)-fo(2)*fi(4)) )*d
         else
            d = d*gc(1)
            jio(1) =  ( fo(3)*fi(1)+fo(4)*fi(2))*d
            jio(2) = -( fo(3)*fi(2)+fo(4)*fi(1))*d
            jio(3) =  ( fo(3)*fi(2)-fo(4)*fi(1))*d*cImag
            jio(4) =  (-fo(3)*fi(1)+fo(4)*fi(2))*d
         end if

      end if
c
      return
      end


text:
module lfortran_intrinsic_bit
use, intrinsic :: iso_fortran_env, only: int32, int64
implicit none

interface iand
    module procedure iand32, iand64
end interface

interface not
    module procedure not32, not64
end interface

interface ior
    module procedure ior32, ior64
end interface

interface ieor
    module procedure ieor32, ieor64
end interface

interface ibclr
    module procedure ibclr32, ibclr64
end interface

interface ibset
    module procedure ibset32, ibset64
end interface

interface btest
    module procedure btest32, btest64
end interface

interface ishft
    module procedure ishft32, ishft64
end interface

interface mvbits
    module procedure mvbits32, mvbits64
end interface

interface bge
    module procedure bge32, bge64
end interface

interface bgt
    module procedure bgt32, bgt64
end interface

interface ble
    module procedure ble32, ble64
end interface

interface blt
    module procedure blt32, blt64
end interface

interface ibits
    module procedure ibits32, ibits64
end interface

contains

! iand --------------------------------------------------------------------------

elemental integer(int32) function iand32(x, y) result(r)
integer(int32), intent(in) :: x
integer(int32), intent(in) :: y
interface
    pure integer(int32) function c_iand32(x, y) bind(c, name="_lfortran_iand32")
    import :: int32
    integer(int32), intent(in), value :: x
    integer(int32), intent(in), value :: y
    end function
end interface
r = c_iand32(x, y)
end function

elemental integer(int64) function iand64(x, y) result(r)
integer(int64), intent(in) :: x
integer(int64), intent(in) :: y
interface
    pure integer(int64) function c_iand64(x, y) bind(c, name="_lfortran_iand64")
    import :: int64
    integer(int64), intent(in), value :: x
    integer(int64), intent(in), value :: y
    end function
end interface
r = c_iand64(x, y)
end function

! not --------------------------------------------------------------------------

elemental integer(int32) function not32(x) result(r)
integer(int32), intent(in) :: x
interface
    pure integer(int32) function c_not32(x) bind(c, name="_lfortran_not32")
    import :: int32
    integer(int32), intent(in), value :: x
    end function
end interface
r = c_not32(x)
end function

elemental integer(int64) function not64(x) result(r)
integer(int64), intent(in) :: x
interface
    pure integer(int64) function c_not64(x) bind(c, name="_lfortran_not64")
    import :: int64
    integer(int64), intent(in), value :: x
    end function
end interface
r = c_not64(x)
end function

! ior --------------------------------------------------------------------------

elemental integer(int32) function ior32(x, y) result(r)
integer(int32), intent(in) :: x
integer(int32), intent(in) :: y
interface
    pure integer(int32) function c_ior32(x, y) bind(c, name="_lfortran_ior32")
    import :: int32
    integer(int32), intent(in), value :: x
    integer(int32), intent(in), value :: y
    end function
end interface
r = c_ior32(x, y)
end function

elemental integer(int64) function ior64(x, y) result(r)
integer(int64), intent(in) :: x
integer(int64), intent(in) :: y
interface
    pure integer(int64) function c_ior64(x, y) bind(c, name="_lfortran_ior64")
    import :: int64
    integer(int64), intent(in), value :: x
    integer(int64), intent(in), value :: y
    end function
end interface
r = c_ior64(x, y)
end function

! ieor --------------------------------------------------------------------------

elemental integer(int32) function ieor32(x, y) result(r)
integer(int32), intent(in) :: x
integer(int32), intent(in) :: y
interface
    pure integer(int32) function c_ieor32(x, y) bind(c, name="_lfortran_ieor32")
    import :: int32
    integer(int32), intent(in), value :: x
    integer(int32), intent(in), value :: y
    end function
end interface
r = c_ieor32(x, y)
end function

elemental integer(int64) function ieor64(x, y) result(r)
integer(int64), intent(in) :: x
integer(int64), intent(in) :: y
interface
    pure integer(int64) function c_ieor64(x, y) bind(c, name="_lfortran_ieor64")
    import :: int64
    integer(int64), intent(in), value :: x
    integer(int64), intent(in), value :: y
    end function
end interface
r = c_ieor64(x, y)
end function

! ibclr --------------------------------------------------------------------------

elemental integer(int32) function ibclr32(i, pos) result(r)
integer(int32), intent(in) :: i
integer, intent(in) :: pos
interface
    pure integer(int32) function c_ibclr32(i, pos) bind(c, name="_lfortran_ibclr32")
    import :: int32
    integer(int32), intent(in), value :: i
    integer, intent(in), value :: pos
    end function
end interface

if (pos >= 0 .and. pos < 32) then
    r = c_ibclr32(i, pos)
else
    error stop "ibclr(i, pos) for pos < 0 or pos >= bit_size(i) is not allowed"
end if
end function

elemental integer(int64) function ibclr64(i, pos) result(r)
integer(int64), intent(in) :: i
integer, intent(in) :: pos
interface
    pure integer(int64) function c_ibclr64(i, pos) bind(c, name="_lfortran_ibclr64")
    import :: int64
    integer(int64), intent(in), value :: i
    integer, intent(in), value :: pos
    end function
end interface

if (pos >= 0 .and. pos < 64) then
    r = c_ibclr64(i, pos)
else
    error stop "ibclr(i, pos) for pos < 0 or pos >= bit_size(i) is not allowed"
end if
end function

! ibset --------------------------------------------------------------------------

elemental integer(int32) function ibset32(i, pos) result(r)
integer(int32), intent(in) :: i
integer, intent(in) :: pos
interface
    pure integer(int32) function c_ibset32(i, pos) bind(c, name="_lfortran_ibset32")
    import :: int32
    integer(int32), intent(in), value :: i
    integer, intent(in), value :: pos
    end function
end interface

if (pos >= 0 .and. pos < 32) then
    r = c_ibset32(i, pos)
else
    error stop "ibset(i, pos) for pos < 0 or pos >= bit_size(i) is not allowed"
end if
end function

elemental integer(int64) function ibset64(i, pos) result(r)
integer(int64), intent(in) :: i
integer, intent(in) :: pos
interface
    pure integer(int64) function c_ibset64(i, pos) bind(c, name="_lfortran_ibset64")
    import :: int64
    integer(int64), intent(in), value :: i
    integer, intent(in), value :: pos
    end function
end interface

if (pos >= 0 .and. pos < 64) then
    r = c_ibset64(i, pos)
else
    error stop "ibset(i, pos) for pos < 0 or pos >= bit_size(i) is not allowed"
end if
end function

! btest --------------------------------------------------------------------------

elemental logical function btest32(i, pos) result(r)
integer(int32), intent(in) :: i
integer, intent(in) :: pos
interface
    pure integer(int32) function c_btest32(i, pos) bind(c, name="_lfortran_btest32")
    import :: int32
    integer(int32), intent(in), value :: i
    integer, intent(in), value :: pos
    end function
end interface

if (pos >= 0 .and. pos < 32) then
    r = c_btest32(i, pos) /= 0
else
    error stop "btest(i, pos) for pos < 0 or pos >= bit_size(i) is not allowed"
end if
end function

elemental logical function btest64(i, pos) result(r)
integer(int64), intent(in) :: i
integer, intent(in) :: pos
interface
    pure integer(int64) function c_btest64(i, pos) bind(c, name="_lfortran_btest64")
    import :: int64
    integer(int64), intent(in), value :: i
    integer, intent(in), value :: pos
    end function
end interface

if (pos >= 0 .and. pos < 64) then
    r = c_btest64(i, pos) /= 0
else
    error stop "btest(i, pos) for pos < 0 or pos >= bit_size(i) is not allowed"
end if
end function

! ishft ------------------------------------------------------------------------

elemental integer(int32) function ishft32(i, shift) result(r)
integer(int32), intent(in) :: i, shift
interface
    pure integer(int32) function c_ishft32(i, shift) bind(c, name="_lfortran_ishft32")
        import :: int32
        integer(int32), intent(in), value :: i, shift
    end function
end interface

if (shift < 32) then
    r = c_ishft32(i, shift)
else
    error stop "shift must be less than 32"
end if
end function

elemental integer(int64) function ishft64(i, shift) result(r)
integer(int64), intent(in) :: i, shift
interface
    pure integer(int64) function c_ishft64(i, shift) bind(c, name="_lfortran_ishft64")
        import :: int64
        integer(int64), intent(in), value :: i, shift
    end function
end interface

if (shift < 64) then
    r = c_ishft64(i, shift)
else
    error stop "shift must be less than 64"
end if
end function

! mvbits ------------------------------------------------------------------------

elemental subroutine mvbits32(from, frompos, len, to, topos)
integer(int32), intent(in) :: from, frompos, len, topos
integer(int32), intent(out) :: to
interface
    pure integer(int32) function c_mvbits32(from, frompos, len, to, topos) bind(c, name="_lfortran_mvbits32")
    import :: int32
    integer(int32), intent(in), value :: from, frompos, len, to, topos
    end function
end interface
to = c_mvbits32(from, frompos, len, to, topos)
end subroutine

elemental subroutine mvbits64(from, frompos, len, to, topos)
integer(int64), intent(in) :: from
integer(int32), intent(in) :: frompos, len, topos
integer(int64), intent(out) :: to
interface
    pure integer(int64) function c_mvbits64(from, frompos, len, to, topos) bind(c, name="_lfortran_mvbits64")
    import :: int64, int32
    integer(int64), intent(in), value :: from, to
    integer(int32), intent(in), value :: frompos, len, topos
    end function
end interface
to = c_mvbits64(from, frompos, len, to, topos)
end subroutine

! bge ------------------------------------------------------------------------

elemental logical function bge32(i, j) result(r)
integer(int32), intent(in) :: i, j
interface
    pure logical function c_bge32(i, j) bind(c, name="_lfortran_bge32")
    import :: int32
    integer(int32), intent(in), value :: i, j
    end function
end interface
r = c_bge32(i, j)
end function

elemental logical function bge64(i, j) result(r)
integer(int64), intent(in) :: i, j
interface
    pure logical function c_bge64(i, j) bind(c, name="_lfortran_bge64")
    import :: int64
    integer(int64), intent(in), value :: i, j
    end function
end interface
r = c_bge64(i, j)
end function

! bgt ------------------------------------------------------------------------

elemental logical function bgt32(i, j) result(r)
integer(int32), intent(in) :: i, j
interface
    pure logical function c_bgt32(i, j) bind(c, name="_lfortran_bgt32")
    import :: int32
    integer(int32), intent(in), value :: i, j
    end function
end interface
r = c_bgt32(i, j)
end function

elemental logical function bgt64(i, j) result(r)
integer(int64), intent(in) :: i, j
interface
    pure logical function c_bgt64(i, j) bind(c, name="_lfortran_bgt64")
    import :: int64
    integer(int64), intent(in), value :: i, j
    end function
end interface
r = c_bgt64(i, j)
end function

! ble ------------------------------------------------------------------------

elemental logical function ble32(i, j) result(r)
integer(int32), intent(in) :: i, j
interface
    pure logical function c_ble32(i, j) bind(c, name="_lfortran_ble32")
    import :: int32
    integer(int32), intent(in), value :: i, j
    end function
end interface
r = c_ble32(i, j)
end function

elemental logical function ble64(i, j) result(r)
integer(int64), intent(in) :: i, j
interface
    pure logical function c_ble64(i, j) bind(c, name="_lfortran_ble64")
    import :: int64
    integer(int64), intent(in), value :: i, j
    end function
end interface
r = c_ble64(i, j)
end function

! blt ------------------------------------------------------------------------

elemental logical function blt32(i, j) result(r)
integer(int32), intent(in) :: i, j
interface
    pure logical function c_blt32(i, j) bind(c, name="_lfortran_blt32")
    import :: int32
    integer(int32), intent(in), value :: i, j
    end function
end interface
r = c_blt32(i, j)
end function

elemental logical function blt64(i, j) result(r)
integer(int64), intent(in) :: i, j
interface
    pure logical function c_blt64(i, j) bind(c, name="_lfortran_blt64")
    import :: int64
    integer(int64), intent(in), value :: i, j
    end function
end interface
r = c_blt64(i, j)
end function

! ibits ------------------------------------------------------------------------

elemental integer(int32) function ibits32(i, pos, len) result(r)
integer(int32), intent(in) :: i, pos, len
interface
    pure integer(int32) function c_ibits32(i, pos, len) bind(c, name="_lfortran_ibits32")
    import :: int32
    integer(int32), intent(in), value :: i, pos, len
    end function
end interface
r = c_ibits32(i, pos, len)
end function

elemental integer(int64) function ibits64(i, pos, len) result(r)
integer(int64), intent(in) :: i
integer(int32), intent(in) :: pos, len
interface
    pure integer(int64) function c_ibits64(i, pos, len) bind(c, name="_lfortran_ibits64")
    import :: int32, int64
    integer(int64), intent(in), value :: i
    integer(int32), intent(in), value :: pos, len
    end function
end interface
r = c_ibits64(i, pos, len)
end function

end module

max_stars_repo_name: Thirumalai-Shaktivel/lfortran

max_issues_repo_name: Thirumalai-Shaktivel/lfortran

max_forks_repo_name: Thirumalai-Shaktivel/lfortran


text:
!##############################################################################
!# ****************************************************************************
!# <name> bdryintegralerror </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module calculates the boundary integral error
!#
!#    $$ int_{\Gamma} (u - u_h) * d_n(u)  dx$$
!#
!# of a FE function $u_h$ to a given analytical function $u$.
!# The analytical function $u$ is specified in the callback function
!# bdrierr_referenceFunction.
!#
!# To calculate the integral, the following routine can be used:
!#
!# 1.) bdrierr_calcError
!#     -> Calculates the boundary integral error to the reference function $u$.
!# </purpose>
!##############################################################################

module bdryintegralerror

  use fsystem
  use boundaryintegral

  private :: ffunctionBoundaryError

contains

  !****************************************************************************

!<subroutine>

  subroutine bdrierr_referenceFunction (dx,dy,dvalue,dderivX,dderivY)

!<description>
  ! USER DEFINED CALLBACK ROUTINE.
  ! This routine calculates in the point (dx,dy) the value of the reference
  ! function $u$.
!</description>

!<input>
  ! Coordinates of the point.
  real(DP), intent(IN) :: dx,dy
!</input>

!<output>
  ! Value of the reference function.
  real(DP), intent(OUT) :: dvalue

  ! X-derivative
  real(DP), intent(OUT) :: dderivX

  ! Y-derivative
  real(DP), intent(OUT) :: dderivY
!</output>

    dvalue = 0.0_DP
    dderivX = 0.0_DP
    dderivY = 0.0_DP

  end subroutine

  !****************************************************************************

!<subroutine>

  subroutine bdrierr_calcError (rvectorScalar,ccubType,dvalue,rboundaryRegion)

!<description>
  ! Calculates the boundary integral error to the reference function $u$.
  ! To calculate the analytical values of the reference function,
  ! the subroutine bdrierr_referenceFunction is called.
  !
  ! rboundaryRegion allows to specify a region on the boundary where
  ! the integral is computed; if not specified, the integral is
  ! computed over the whole boundary.
!</description>

!<input>
  ! A scalar FE function to compute a boundary integral of.
  type(t_vectorScalar), intent(IN) :: rvectorScalar

  ! A line cubature formula CUB_xxxx_1D to be used for line integration.
  integer, intent(IN) :: ccubType

  ! OPTIONAL: A t_boundaryRegion specifying the boundary region where
  ! to calculate. If not specified, the computation is done over
  ! the whole boundary.
  type(t_boundaryRegion), intent(IN), optional :: rboundaryRegion
!</input>

!<output>
  ! The calculated value of the integral.
  real(DP), intent(OUT) :: dvalue
!</output>

    ! local variables
    type(t_spatialDiscretisation), pointer :: p_rdiscr
    type(t_collection) :: rcollection

    ! Get the underlying discretisation
    p_rdiscr => rvectorScalar%p_rspatialDiscretisation

    ! Create a collection that allows us to pass the vector to
    ! the callback routine
    call collct_init(rcollection)

    ! Save the vector to the collection, so we can restore it in
    ! the callback routine
    call collct_setvalue_vecsca (rcollection, 'vector', rvectorScalar, .true.)

    call bdint_integral2D (p_rdiscr%p_rboundary,p_rdiscr%p_rtriangulation,&
      ccubType,ffunctionBoundaryError,dvalue,rboundaryRegion,rcollection)

    ! Release the collection
    call collct_deletevalue (rcollection,'vector')
    call collct_done(rcollection)

  end subroutine

  !****************************************************************************

  !<subroutine>

  subroutine ffunctionBoundaryError (DpointsRef, Dpoints, ibct, DpointPar, Ielements, &
        p_rcollection, Dvalues)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! AUXILIARY FUNCTION.
    ! This subroutine is called during the calculation of the boundary
    ! integral, initiated by bdrierr_calcError. It computes the (analytical)
    ! values of a function in a couple of points Dpoints on a couple of elements
    ! Ielements. The integral evaluation function uses these values
    ! to compute integrals.
    !
    ! To evaluate the reference function, bdrierr_referenceFunction is
    ! called.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in in real and reference coordinates.
    ! It has to to simultaneously compute the desired values for all these points.
  !</description>

  !<input>
    ! This is an array of all points on all the elements where coefficients
    ! are needed. It specifies the coordinates of the points where
    ! information is needed. These coordinates correspond to the reference
    ! element.
    ! DIMENSION(NDIM2D,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(IN)  :: DpointsRef

    ! This is an array of all points on all the elements where coefficients
    ! are needed. It specifies the coordinates of the points where
    ! information is needed. These coordinates are world coordinates,
    ! i.e. on the real element.
    ! DIMENSION(NDIM2D,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(IN)  :: Dpoints

    ! This is the number of the boundary component that contains the
    ! points in Dpoint. All points are on the same boundary component.
    integer, intent(IN) :: ibct

    ! For every point under consideration, this specifies the parameter
    ! value of the point on the boundary component. The parameter value
    ! is calculated in LENGTH PARAMETRISATION!
    ! DIMENSION(npointsPerElement,nelements)
    real(DP), dimension(:,:), intent(IN) :: DpointPar

    ! This is a list of elements (corresponding to Dpoints) where information
    ! is needed. To an element iel=Ielements(i), the array Dpoints(:,:,i)
    ! specifies the points where information is needed.
    ! DIMENSION(nelements)
    integer(PREC_ELEMENTIDX), dimension(:), intent(IN) :: Ielements

    ! A pointer to a collection structure to provide additional
    ! information to the coefficient routine. May point to NULL() if not defined.
    type(t_collection), pointer                      :: p_rcollection
  !</input>

  !<output>
    ! This array has to receive the values of the (analytical) function
    ! in all the points specified in Dpoints, or the appropriate derivative
    ! of the function, respectively, according to cderivative.
    !   DIMENSION(npointsPerElement,nelements)
    real(DP), dimension(:,:), intent(OUT)                      :: Dvalues
  !</output>

  !</subroutine>

    ! local variables
    type(t_vectorScalar), pointer :: p_rvector
    type(t_boundary), pointer :: p_rboundary
    real(DP), dimension(:,:), allocatable :: Duh
    real(DP), dimension(:,:,:), allocatable :: Du
    integer(PREC_ELEMENTIDX) :: iel
    integer :: ipoint
    real(DP) :: dminPar,dmaxPar
    real(DP) :: dnx,dny,dt

    ! Get the vector with the FE function from the collection
    ! and to the boundary definition
    p_rvector => collct_getvalue_vecsca (p_rcollection, 'vector')
    p_rboundary => p_rvector%p_rspatialDiscretisation%p_rboundary

    ! Allocate memory for the FE-function and for the analytical values.
    ! DU(1,:,:) = function value,
    ! DU(2,:,:) = X-derivative,
    ! DU(3,:,:) = Y-derivative
    allocate(Duh(ubound(Dvalues,1),ubound(Dvalues,2)))
    allocate(Du(3,ubound(Dvalues,1),ubound(Dvalues,2)))

    do iel=1,size(Ielements)
      ! Evaluate the FE function in the given points.
      call fevl_evaluate_mult (DER_FUNC, Duh(:,iel), p_rvector, &
          Ielements(iel), DpointsRef(:,:,iel), Dpoints(:,:,iel))

      ! Evaluate the analytical function in the given points
      do ipoint = 1,ubound(Dvalues,1)
        call bdrierr_referenceFunction (&
            Dpoints(1,ipoint,iel),Dpoints(2,ipoint,iel),&
            Du(1,ipoint,iel),Du(2,ipoint,iel),Du(3,ipoint,iel))
      end do
    end do

    ! Get the minimum and maximum parameter value. The point with the minimal
    ! parameter value is the start point of the interval, the point with the
    ! maximum parameter value the endpoint.
    dminPar = DpointPar(1,1)
    dmaxPar = DpointPar(1,1)
    do iel=1,size(Ielements)
      do ipoint = 1,ubound(Dpoints,1)
        dminPar = min(DpointPar(ipoint,iel),dminPar)
        dmaxPar = max(DpointPar(ipoint,iel),dmaxPar)
      end do
    end do

    ! Calculate the value of the term in the integral in that point.
    do iel=1,size(Ielements)

      ! Evaluate the analytical function in the given points
      do ipoint = 1,ubound(Dvalues,1)

        ! Parameter value of the point -- in length parametrisation!
        dt = DpointPar(ipoint,iel)

        ! Get the normal vector in the point from the boundary.
        ! Note that the parameter value is in length parametrisation!
        ! When we are at the left or right endpoint of the interval, we
        ! calculate the normal vector based on the current edge.
        ! Without that, the behaviour of the routine may lead to some
        ! confusion if the endpoints of the interval coincide with
        ! the endpoints of a boundary edge. In such a case, the routine
        ! would normally compute the normal vector as a mean on the
        ! normal vectors of the edges adjacent to such a point!
        if (dt .eq. dminPar) then
          ! Start point
          call boundary_getNormalVec2D(p_rboundary, ibct, &
              dt, dnx, dny,BDR_NORMAL_RIGHT,BDR_PAR_LENGTH)
        else if (dt .eq. dmaxPar) then
          ! End point
          call boundary_getNormalVec2D(p_rboundary, ibct, &
              dt, dnx, dny,BDR_NORMAL_LEFT,BDR_PAR_LENGTH)
        else
          ! Inner point
          call boundary_getNormalVec2D(p_rboundary, ibct, &
              dt, dnx, dny,cparType=BDR_PAR_LENGTH)
        end if

        ! Calculate the function value: (u-u_h) d_n(u)
        Dvalues(ipoint,iel) = &
            ( Du(1,ipoint,iel) - Duh(ipoint,iel)) * &
            ( Du(2,ipoint,iel)*dnx + Du(3,ipoint,iel)*dny )

      end do

    end do

    ! Release memory
    deallocate(Du,Duh)

  end subroutine

end module

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
      subroutine tmpcft
c
c     + + + PURPOSE + + +
c
c     Fit an air temperature curve form longterm monthly temperature data
c      Codes of Newton method was adapted from Li Wang
c
c     Called from: SR WINIT
c     Author(s): Li Wang, Shuhui Dun, WSU
c     Reference in User Guide: choose minimum square root error
c
c     Version: 2008.
c     Date recoded: January 07, 2008
c     Verified by : Joan Wu, WSU
c

c
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxpln.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c
c     + + + COMMON BLOCKS + + +
c
      include 'cobclim.inc'
c     Read: obmaxt, obmint
c
      include 'ctcurv.inc'
c     Modify: YavgT,YampT,YpshfT,obavgT
c
c     + + + LOCAL VARIABLES + + +
c
      integer  i,nir
      real Fpcal,Fmin,Mmaxt,Mmint,tol,dpshft,fsdsqe,sddsqe,ThetaT,pai
      real tmpfun,tday
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Fp0, Fp1,Fpcal: function value (mean square error) of corresponding points
c     Fmin: minimum mean square error
c     tol: tolerance
c      Mmaxt: Maximum monthly temperature
c     Mmint: Minimum monthly temperature
c      dpshft: Delta phase shift
c      fsdsqe: First order derivative of the square error
c     sddsqe: second order derivative of the square error
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c
c     + + + DATA INITIALIZATIONS + + +
      tol = 0.00001
      Mmaxt = -100
      Mmint = 100
      pai=acos(-1.0)
c
c     + + + END SPECIFICATIONS + + +
c
cd      Added by S. Dun, Jan 05, 2008
c      For a long term yearly average temperature in frost simulation
      yavgt = 0
c
      do 10 i = 1, 12
         obavgt(i) = (obmaxt(i) + obmint(i))/2.0
         if (Mmaxt.lt.obavgt(i))  Mmaxt = obavgt(i)
         if (Mmint.gt.obavgt(i))  Mmint = obavgt(i)
         yavgt = yavgt + obavgt(i)
10    continue
c
      yavgt = yavgt/12.
      YampT = (Mmaxt - Mmint)/2.0
c
      if (YpshfT.gt. 0) then
c      check if the Ypshft could be directly used
            if (tmpfun(YpshfT) .lt. 2.0) return
      endif
c
c     Newton method
      dpshft = 1
      nir = 0
      YpshfT = 0

      Do while ((abs(dpshft).gt. tol).and. (nir.lt.20))

         fsdsqe = 0.0
         sddsqe = 0.0
         nir = nir +1

         Do 30 i = 1, 12
             tday = 15. + (i-1)* 30.5
             ThetaT = 2.*pai/365. *(tday-YpshfT)

             fsdsqe = fsdsqe -(YavgT + YampT * sin(thetaT) -obavgt(i))
     1                * cos(thetaT)
c
             sddsqe = sddsqe - 2.*pai/365.*
     1        ((YavgT - obavgt(i))*sin(thetaT) - YampT*cos(2.*thetaT))
30        continue
c
            if(sddsqe .lt. 0.) then
              YpshfT = YpshfT + 365.0/2.0
            else
c
                dpshft = - fsdsqe/sddsqe
                Ypshft = ypshft + dpshft
c
              Ypshft = mod(Ypshft,365.0)
              if (Ypshft.lt.0) Ypshft = Ypshft + 365.0
          endif
c
40      enddo
c
cd    The alternative method if Newton Mehtod would not converge after 20 iterations
      if(nir.ge.20) then
c      chose minimum square root error
          Fmin = tmpfun(0.)
          YpshfT = 0
c
          do 20 i = 1, 365
              Fpcal = tmpfun(float(i))
                if (Fpcal.lt.Fmin) then
                  Fmin = Fpcal
                  YpshfT = i
              endif
20        continue
      endif

      return
      end

max_stars_repo_name: jarad/dep

max_issues_repo_name: jarad/dep

max_forks_repo_name: akrherz/idep


text:
!***********************************************************************
! Routes water between segments in the system using Muskingum routing
!
!   The Muskingum equation is described in 'Hydrology for Engineers', 3rd ed.
!   by Linsley, R.K, Kohler, M.A., and Paulhus, J.L.H., 1982 p. 275 and in
!   'Water in Environmental Planning' by Dunne, T., and Leopold, L.B. 1978
!   p. 357.
!
!   Note that the Muskingum equation assumes a linear relation of storage
!   to the inflow/outflow relation and therefore the relation is the same
!   throughout the range of the hydrograph.  The route_time parameter in
!   the fixroute module is replaced by two new parameters, K_coef and
!   x_coef, which are described below:
!
!   The Muskingum method is based on the equation: S = K[xI + (1 - x)O]
!     where S is storage, K is the storage coefficient, x is a coefficient
!     between 0 and .5, I is inflow, and O is outflow.
!
!   Solving for the outflow at day 2,O2; and knowing the inflow at day 1,
!   I1; the inflow at day 2,I2; and the outflow at day 1, O1; the storage
!   equation can be written as follows:
!
!        O2 = czero*I2 + cone*I1 + ctwo*O1
!
!     where czero = -((Kx - 12)    / (K - Kx + 12))
!           cone  =  (Kx + 12)     / (K - Kx + 12)
!           ctwo  =  (K - Kx - 12) / (K - Kx + 12)
!
!     assuming a time step of one day and K is in units of hours
!
!   This module is based on the "musroute.f" module. It differs in three
!   basic ways:
!
!   1. This module uses an internal routing time step of one hour.
!      The old muskingum module ran on the same daily time step as
!      the rest of PRMS. The problem with this is that there is no
!      ability to distinguish where the flood wave (front of the flow
!      change) within the segment. For example, if there is a series
!      of 4 1-day long segments, a flood wave will make it to the bottom
!      of these in 1 day. If the same system is modeled as 1 4-day long
!      segment, it will take 4 days.
!
!   2. The X parameter has been removed as a specified input and is now computed. To
!      my knowledge, no modeler had ever set this to anything other than the default
!      value (0.2) anyway. Always using the default value can lead to problems
!      with the C coffecients which can result in mass balance problems or negative
!      flow values.
!
!      To solve this problem, I assume that the C coefficients must
!      always be between 0 and 1. By setting the C coefficients equal to 0 and 1,
!      various limits on the time step (ts), X, and K can be determined. There are
!      two of these limits which are of interest:
!
!      When C0 = 0:
!             ts
!        K = -----
!             2X
!
!      When C2 = 0:
!            ts
!       K = -----
!           2(1-X)
!
!      Determining a value of K half way between these two limits (by averaging)
!      and solving for X using the quadratic formula results in:
!
!            1-sqrt(1-(ts/K))
!       X = ------------------
!                  2
!
!       So when ts is fixed at one hour and K is fixed as the average (or expected)
!       travel time corresponding to the segment (for each segment in the stream
!       network), a value of X can be computed (for each segment in the stream
!       network) which will result in both conservation of mass and non-negative
!       flows. Another benefit is that only one input parameter (K) needs to be
!       input to the module.
!
!   3. If the travel time of a segment is less than or equal to the routing
!      time step (one hour), then the outflow of the segment is set to the
!      value of the inflow.
!
!***********************************************************************
      MODULE PRMS_MUSKINGUM
      IMPLICIT NONE
!   Local Variables
      DOUBLE PRECISION, PARAMETER :: ONE_24TH = 1.0D0 / 24.0D0
      INTEGER, SAVE, ALLOCATABLE :: Ts_i(:)
      REAL, SAVE, ALLOCATABLE :: Ts(:), C0(:), C1(:), C2(:)
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Currinsum(:), Pastin(:), Pastout(:)
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:), Inflow_ts(:)
      CHARACTER(LEN=9), SAVE :: MODNAME
!   Declared Variables
      DOUBLE PRECISION, SAVE :: Basin_segment_storage
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Segment_delta_flow(:)
!   Declared Parameters
      REAL, SAVE, ALLOCATABLE :: K_coef(:), X_coef(:), Segment_flow_init(:)
      END MODULE PRMS_MUSKINGUM

!***********************************************************************
!     Main muskingum routine
!***********************************************************************
      INTEGER FUNCTION muskingum()
      USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file
      IMPLICIT NONE
! Functions
      INTEGER, EXTERNAL :: muskingum_decl, muskingum_init, muskingum_run
      EXTERNAL :: muskingum_restart
!***********************************************************************
      muskingum = 0

      IF ( Process(:3)=='run' ) THEN
        muskingum  = muskingum_run()
      ELSEIF ( Process(:4)=='decl' ) THEN
        muskingum  = muskingum_decl()
      ELSEIF ( Process(:4)=='init' ) THEN
        IF ( Init_vars_from_file==1 ) CALL muskingum_restart(1)
        muskingum = muskingum_init()
      ELSEIF ( Process(:5)=='clean' ) THEN
        IF ( Save_vars_to_file==1 ) CALL muskingum_restart(0)
      ENDIF

      END FUNCTION muskingum

!***********************************************************************
!     muskingum_decl - Declare parameters and variables and allocate arrays
!   Declared Parameters
!     tosegment, hru_segment, obsin_segment, K_coef, x_coef
!***********************************************************************
      INTEGER FUNCTION muskingum_decl()
      USE PRMS_MUSKINGUM
      USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file
      IMPLICIT NONE
! Functions
      INTEGER, EXTERNAL :: declparam, declvar
      EXTERNAL read_error, print_module
! Local Variables
      CHARACTER(LEN=80), SAVE :: Version_muskingum
!***********************************************************************
      muskingum_decl = 0

      Version_muskingum = 'muskingum.f90 2016-07-25 12:06:00Z'
      CALL print_module(Version_muskingum, 'Streamflow Routing          ', 90)
      MODNAME = 'muskingum'

      ALLOCATE ( C1(Nsegment), C2(Nsegment), C0(Nsegment), Ts(Nsegment) )
      ALLOCATE ( Currinsum(Nsegment), Ts_i(Nsegment) )
      ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) )
      ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) )

      IF ( declvar(MODNAME, 'basin_segment_storage', 'one', 1, 'double', &
     &     'Basin area-weighted average storage in the stream network', &
     &     'inches', Basin_segment_storage)/=0 ) CALL read_error(3, 'basin_segment_storage')

      ALLOCATE ( Segment_delta_flow(Nsegment) )
      IF ( declvar(MODNAME, 'segment_delta_flow', 'nsegment', Nsegment, 'double', &
     &     'Cummulative flow in minus flow out for each stream segment', &
     &     'cfs', Segment_delta_flow)/=0 ) CALL read_error(3, 'segment_delta_flow')

      ALLOCATE ( K_coef(Nsegment) )
      IF ( declparam(MODNAME, 'K_coef', 'nsegment', 'real', &
     &     '1.0', '0.01', '24.0', &
     &     'Muskingum storage coefficient', &
     &     'Travel time of flood wave from one segment to the next downstream segment,'// &
     &     ' called the Muskingum storage coefficient; enter 1.0 for reservoirs,'// &
     &     ' diversions, and segment(s) flowing out of the basin', &
     &     'hours')/=0 ) CALL read_error(1, 'K_coef')

      ALLOCATE ( X_coef(Nsegment) )
      IF ( declparam(MODNAME, 'x_coef', 'nsegment', 'real', &
     &     '0.2', '0.0', '0.5', &
     &     'Routing weighting factor', &
     &     'The amount of attenuation of the flow wave, called the'// &
     &     ' Muskingum routing weighting factor; enter 0.0 for'// &
     &     ' reservoirs, diversions, and segment(s) flowing out of the basin', &
     &     'decimal fraction')/=0 ) CALL read_error(1, 'x_coef')

      IF ( Init_vars_from_file==0 ) THEN
        ALLOCATE ( Segment_flow_init(Nsegment) )
        IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', &
     &       '0.0', '0.0', '1.0E7', &
     &       'Initial flow in each stream segment', &
     &       'Initial flow in each stream segment', &
     &       'cfs')/=0 ) CALL read_error(1, 'segment_flow_init')
      ENDIF

      END FUNCTION muskingum_decl

!***********************************************************************
!    muskingum_init - Get and check parameter values and initialize variables
!***********************************************************************
      INTEGER FUNCTION muskingum_init()
      USE PRMS_MUSKINGUM
      USE PRMS_MODULE, ONLY: Nsegment, Inputerror_flag, Parameter_check_flag, &
     &    Init_vars_from_file
      USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv
      USE PRMS_FLOWVARS, ONLY: Seg_inflow, Seg_outflow
      USE PRMS_SET_TIME, ONLY: Cfs_conv
      IMPLICIT NONE
      EXTERNAL :: read_error
      INTEGER, EXTERNAL :: getparam
! Local Variables
      INTEGER :: i, ierr
      REAL :: k, x, d, x_max
!***********************************************************************
      muskingum_init = 0

      IF ( getparam(MODNAME, 'K_coef', Nsegment, 'real', K_coef)/=0 ) CALL read_error(2, 'K_coef')
      IF ( getparam(MODNAME, 'x_coef', Nsegment, 'real', X_coef)/=0 ) CALL read_error(2, 'x_coef')
      IF ( Init_vars_from_file==0 ) THEN
        IF ( getparam(MODNAME, 'segment_flow_init',  Nsegment, 'real', Segment_flow_init)/=0 ) &
     &       CALL read_error(2,'segment_flow_init')
        Seg_inflow = 0.0D0
        DO i = 1, Nsegment
          Seg_outflow(i) = Segment_flow_init(i)
        ENDDO
        DEALLOCATE ( Segment_flow_init )
        Segment_delta_flow = 0.0D0
        Outflow_ts = 0.0D0
      ENDIF
!
!     Compute the three constants in the Muskingum routing equation based
!     on the values of K_coef and a routing period of 1 hour. See the notes
!     at the top of this file.

!
      C0 = 0.0
      C1 = 0.0
      C2 = 0.0
!make sure K>0
      Ts = 1.0
      ierr = 0
      Basin_segment_storage = 0.0D0
      DO i = 1, Nsegment
        Basin_segment_storage = Basin_segment_storage + Seg_outflow(i)
        k = K_coef(i)
        x = X_coef(i)

! check the values of k and x to make sure that Muskingum routing is stable

        IF ( k<1.0 ) THEN
!          IF ( Parameter_check_flag>0 ) THEN
!            PRINT '(/,A,I6,A,F6.2,/,9X,A,/)', 'WARNING, segment ', i, ' has K_coef < 1.0,', k, &
!     &            'this may produce unstable results'
!            ierr = 1
!          ENDIF
          Ts(i) = 0.0
          Ts_i(i) = -1

        ELSEIF ( k<2.0 ) THEN
          Ts(i) = 1.0
          Ts_i(i) = 1

        ELSEIF ( k<3.0 ) THEN
          Ts(i) = 2.0
          Ts_i(i) = 2

        ELSEIF ( k<4.0 ) THEN
          Ts(i) = 3.0
          Ts_i(i) = 3

        ELSEIF ( k<6.0 ) THEN
          Ts(i) = 4.0
          Ts_i(i) = 4

        ELSEIF ( k<8.0 ) THEN
          Ts(i) = 6.0
          Ts_i(i) = 6

        ELSEIF ( k<12.0 ) THEN
          Ts(i) = 8.0
          Ts_i(i) = 8

        ELSEIF ( k<24.0 ) THEN
          Ts(i) = 12.0
          Ts_i(i) = 12

        ELSE
          Ts(i) = 24.0
          Ts_i(i) = 24

        ENDIF

!  x must be <= t/(2K) the C coefficents will be negative. Check for this for all segments
!  with Ts >= minimum Ts (1 hour).
        IF ( Ts(i)>0.1 ) THEN
          x_max = Ts(i) / (2.0 * k)
          IF ( x>x_max ) THEN
            PRINT *, 'ERROR, x_coef value is too large for stable routing for segment:', i, ' x_coef:', x
            PRINT *, '       a maximum value of:', x_max, ' is suggested'
            Inputerror_flag = 1
            CYCLE
          ENDIF
        ENDIF

        d = k - (k * x) + (0.5 * Ts(i))
        IF ( d==0.0 ) THEN
          PRINT *, 'ERROR, segment ', i, ' computed value d = 0.0, change values of K_coef and x_coef'
          Inputerror_flag = 1
        ENDIF
        C0(i) = (-(k * x) + (0.5 * Ts(i))) / d
        C1(i) = ((k * x) + (0.5 * Ts(i))) / d
        C2(i) = (k - (k * x) - (0.5 * Ts(i))) / d

        ! the following code was in the original musroute, but, not in Linsley and others
        ! rsr, 3/1/2016 - having < 0 coefficient can cause negative flows as found by Jacob in GCPO headwater
!  if c2 is <= 0.0 then  short travel time though reach (less daily
!  flows), thus outflow is mainly = inflow w/ small influence of previous
!  inflow. Therefore, keep c0 as is, and lower c1 by c2, set c2=0

!  if c0 is <= 0.0 then long travel time through reach (greater than daily
!  flows), thus mainly dependent on yesterdays flows.  Therefore, keep
!  c2 as is, reduce c1 by c0 and set c0=0
! SHORT travel time
        IF ( C2(i)<0.0 ) THEN
          IF ( Parameter_check_flag>0 ) THEN
            PRINT '(/,A)', 'WARNING, c2 < 0, set to 0, c1 set to c1 + c2'
            PRINT *, '        old c2:', C2(i), '; old c1:', C1(i), '; new c1:', C1(i) + C2(i)
            PRINT *, '        K_coef:', K_coef(i), '; x_coef:', x_coef(i)
          ENDIF
          C1(i) = C1(i) + C2(i)
          C2(i) = 0.0
        ENDIF

! LONG travel time
        IF ( C0(i)<0.0 ) THEN
          IF ( Parameter_check_flag>0 ) THEN
            PRINT '(/,A)', 'WARNING, c0 < 0, set to 0, c0 set to c1 + c0'
            PRINT *, '      old c0:', C0(i), 'old c1:', C1(i), 'new c1:', C1(i) + C0(i)
            PRINT *, '        K_coef:', K_coef(i), '; x_coef:', x_coef(i)
          ENDIF
          C1(i) = C1(i) + C0(i)
          C0(i) = 0.0
        ENDIF

      ENDDO
      IF ( ierr==1 ) PRINT '(/,A,/)', '***Recommend that the Muskingum parameters be adjusted in the Parameter File'
      DEALLOCATE ( K_coef, X_coef)

      Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv

      END FUNCTION muskingum_init

!***********************************************************************
!     muskingum_run - Compute routing summary values
!***********************************************************************
      INTEGER FUNCTION muskingum_run()
      USE PRMS_MUSKINGUM
      USE PRMS_MODULE, ONLY: Nsegment
      USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, Obsin_segment, Segment_order, Tosegment
      USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, &
     &    Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, Seg_upstream_inflow, &
     &    Seg_lateral_inflow, Flow_out
      USE PRMS_OBS, ONLY: Streamflow_cfs
      USE PRMS_SET_TIME, ONLY: Cfs_conv
      USE PRMS_SRUNOFF, ONLY: Basin_sroff
      USE PRMS_GWFLOW, ONLY: Basin_gwflow
      IMPLICIT NONE
! Functions
      INTRINSIC MOD
! Local Variables
      INTEGER :: i, j, iorder, toseg, imod, tspd
      DOUBLE PRECISION :: area_fac, currin
!***********************************************************************
      muskingum_run = 0

!     SET yesterdays inflows and outflows into temp (past arrays)
!     values may be 0.0 as intial, > 0.0 for runtime and dynamic
!     initial condtions. Then set outlfow and inflow for this time
!     step to 0.0
!
!     upstream_inflow and outflow will vary by hour
!     lateral_inflow and everything else will vary by day
!
!     Compute surface runoff, ssflow, and gwflow going to each segment
!     This is todays "seg_inflow" before additional water is routed to
!     a new (if any is routed)
!
!     For each HRU if the lateral flow for this HRU goes to the
!     segment being evaluated (segment i) then sum flows
!
!     Do these calculations once for the current day, before the hourly
!     routing starts.
!
!       Out2   =      In2*C0    +        In1*C1    +          Out1*C2
!     Seg_outflow = Seg_inflow*Czero + Pastinflow*Cone + Pastoutflow*Ctwo
!       C0, C1, and C2: initialized in the "init" part of this module
!
      Pastin = Seg_inflow
      Pastout = Seg_outflow
      Seg_inflow = 0.0D0
      Seg_outflow = 0.0D0
      Inflow_ts = 0.0D0
      Currinsum = 0.0D0

! 24 hourly timesteps per day
      DO j = 1, 24

        Seg_upstream_inflow = 0.0D0
        DO i = 1, Nsegment
          iorder = Segment_order(i)

! current inflow to the segment is the time weighted average of the outflow
! of the upstream segments plus the lateral HRU inflow plus any gains.
          currin = Seg_lateral_inflow(iorder)
          IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder))
          currin = currin + Seg_upstream_inflow(iorder)
          Seg_inflow(iorder) = Seg_inflow(iorder) + currin
          Inflow_ts(iorder) = Inflow_ts(iorder) + currin
          Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder)

          ! Check to see if this segment is to be routed on this time step
          tspd = Ts_i(iorder)
          imod = MOD( j, tspd )
          IF ( imod==0 ) THEN
            Inflow_ts(iorder) = (Inflow_ts(iorder) / Ts(iorder))
! Compute routed streamflow
            IF ( Ts_i(iorder)>0 ) THEN
! Muskingum routing equation
              Outflow_ts(iorder) = Inflow_ts(iorder)*C0(iorder) + Pastin(iorder)*C1(iorder) + Outflow_ts(iorder)*C2(iorder)
            ELSE
! If travel time (K_coef paremter) is less than or equal to
! time step (one hour), then the outflow is equal to the inflow
! Outflow_ts is the value from last hour
              Outflow_ts(iorder) = Inflow_ts(iorder)
            ENDIF

            ! pastin is equal to the Inflow_ts on the previous routed timestep
            Pastin(iorder) = Inflow_ts(iorder)

! because the upstream inflow from streams is used, reset it to zero so new average
! can be computed next routing timestep.
            Inflow_ts(iorder) = 0.0D0
          ENDIF

          ! Seg_outflow (the mean daily flow rate for each segment) will be the average of the hourly values.
          Seg_outflow(iorder) = Seg_outflow(iorder) + Outflow_ts(iorder)
          ! pastout is equal to the Inflow_ts on the previous routed timestep
          Pastout(iorder) = Outflow_ts(iorder)

! Add current timestep's flow rate to sum the upstream flow rates.
! This can be thought of as a volume because it is a volumetric rate
! (cubic feet per second) over a time step of an hour. Down below when
! this value is used, it will be divided by the number of hours in the
! segment's simulation time step, giving the mean flow rate over that
! period of time.
          toseg = Tosegment(iorder)
          IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Outflow_ts(iorder)

        ENDDO ! segment

      ENDDO  ! timestep

      Basin_segment_storage = 0.0D0
      Flow_out = 0.0D0
      DO i = 1, Nsegment
        Seg_outflow(i) = Seg_outflow(i) * ONE_24TH
        Seg_inflow(i) = Seg_inflow(i) * ONE_24TH
        Seg_upstream_inflow(i) = Currinsum(i) * ONE_24TH
! Flow_out is the total flow out of the basin, which allows for multiple outlets
! includes closed basins (tosegment=0)
        IF ( Tosegment(i)==0 ) Flow_out = Flow_out + Seg_outflow(i)
        Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - Seg_outflow(i)
        Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i)
      ENDDO

      area_fac = Cfs_conv/Basin_area_inv
      Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to stflow_out if replacement flows
      Basin_cfs = Flow_out
      Basin_stflow_out = Basin_cfs / area_fac
      Basin_cms = Basin_cfs*CFS2CMS_CONV
      Basin_sroff_cfs = Basin_sroff*area_fac
      Basin_ssflow_cfs = Basin_ssflow*area_fac
      Basin_gwflow_cfs = Basin_gwflow*area_fac
      Basin_segment_storage = Basin_segment_storage/area_fac

      END FUNCTION muskingum_run

!***********************************************************************
!     muskingum_restart - write or read restart file
!***********************************************************************
      SUBROUTINE muskingum_restart(In_out)
      USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit
      USE PRMS_MUSKINGUM
      IMPLICIT NONE
      ! Argument
      INTEGER, INTENT(IN) :: In_out
      ! Function
      EXTERNAL check_restart
      ! Local Variable
      CHARACTER(LEN=9) :: module_name
!***********************************************************************
      IF ( In_out==0 ) THEN
        WRITE ( Restart_outunit ) MODNAME
        WRITE ( Restart_outunit ) Basin_segment_storage
        WRITE ( Restart_outunit ) Segment_delta_flow
        WRITE ( Restart_outunit ) Outflow_ts
        WRITE ( Restart_outunit ) Pastin
        WRITE ( Restart_outunit ) Pastout
      ELSE
        READ ( Restart_inunit ) module_name
        CALL check_restart(MODNAME, module_name)
        READ ( Restart_inunit ) Basin_segment_storage
        READ ( Restart_inunit ) Segment_delta_flow
        READ ( Restart_inunit ) Outflow_ts
        READ ( Restart_inunit ) Pastin
        READ ( Restart_inunit ) Pastout
      ENDIF
      END SUBROUTINE muskingum_restart

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:
-makelib xcelium_lib/xpm -sv \
  "C:/Xilinx/Vivado/2019.2/data/ip/xpm/xpm_cdc/hdl/xpm_cdc.sv" \
  "C:/Xilinx/Vivado/2019.2/data/ip/xpm/xpm_fifo/hdl/xpm_fifo.sv" \
  "C:/Xilinx/Vivado/2019.2/data/ip/xpm/xpm_memory/hdl/xpm_memory.sv" \
-endlib
-makelib xcelium_lib/xpm \
  "C:/Xilinx/Vivado/2019.2/data/ip/xpm/xpm_VCOMP.vhd" \
-endlib
-makelib xcelium_lib/generic_baseblocks_v2_1_0 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/b752/hdl/generic_baseblocks_v2_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/axi_infrastructure_v1_1_0 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/ec67/hdl/axi_infrastructure_v1_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/axi_register_slice_v2_1_20 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/72d4/hdl/axi_register_slice_v2_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/fifo_generator_v13_2_5 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/276e/simulation/fifo_generator_vlog_beh.v" \
-endlib
-makelib xcelium_lib/fifo_generator_v13_2_5 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/276e/hdl/fifo_generator_v13_2_rfs.vhd" \
-endlib
-makelib xcelium_lib/fifo_generator_v13_2_5 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/276e/hdl/fifo_generator_v13_2_rfs.v" \
-endlib
-makelib xcelium_lib/axi_data_fifo_v2_1_19 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/60de/hdl/axi_data_fifo_v2_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/axi_crossbar_v2_1_21 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/6b0d/hdl/axi_crossbar_v2_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_xbar_0/sim/mb_design_xbar_0.v" \
-endlib
-makelib xcelium_lib/axi_lite_ipif_v3_0_4 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/66ea/hdl/axi_lite_ipif_v3_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/axi_intc_v4_1_14 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/f78a/hdl/axi_intc_v4_1_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_microblaze_0_axi_intc_0/sim/mb_design_microblaze_0_axi_intc_0.vhd" \
-endlib
-makelib xcelium_lib/xlconcat_v2_1_3 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/442e/hdl/xlconcat_v2_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_microblaze_0_xlconcat_0/sim/mb_design_microblaze_0_xlconcat_0.v" \
-endlib
-makelib xcelium_lib/mdm_v3_2_17 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/f9aa/hdl/mdm_v3_2_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_mdm_1_0/sim/mb_design_mdm_1_0.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_clk_wiz_1_0/mb_design_clk_wiz_1_0_clk_wiz.v" \
  "../../../bd/mb_design/ip/mb_design_clk_wiz_1_0/mb_design_clk_wiz_1_0.v" \
-endlib
-makelib xcelium_lib/lib_cdc_v1_0_2 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/ef1e/hdl/lib_cdc_v1_0_rfs.vhd" \
-endlib
-makelib xcelium_lib/proc_sys_reset_v5_0_13 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/8842/hdl/proc_sys_reset_v5_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_rst_clk_wiz_1_100M_0/sim/mb_design_rst_clk_wiz_1_100M_0.vhd" \
-endlib
-makelib xcelium_lib/interrupt_control_v3_1_4 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/a040/hdl/interrupt_control_v3_1_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/axi_gpio_v2_0_22 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/f71e/hdl/axi_gpio_v2_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_axi_gpio_0_0/sim/mb_design_axi_gpio_0_0.vhd" \
  "../../../bd/mb_design/ip/mb_design_axi_gpio_1_0/sim/mb_design_axi_gpio_1_0.vhd" \
  "../../../bd/mb_design/ip/mb_design_axi_gpio_2_0/sim/mb_design_axi_gpio_2_0.vhd" \
  "../../../bd/mb_design/ip/mb_design_axi_gpio_3_0/sim/mb_design_axi_gpio_3_0.vhd" \
-endlib
-makelib xcelium_lib/lib_pkg_v1_0_2 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/0513/hdl/lib_pkg_v1_0_rfs.vhd" \
-endlib
-makelib xcelium_lib/lib_srl_fifo_v1_0_2 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/51ce/hdl/lib_srl_fifo_v1_0_rfs.vhd" \
-endlib
-makelib xcelium_lib/axi_uartlite_v2_0_24 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/d8db/hdl/axi_uartlite_v2_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_axi_uartlite_0_0/sim/mb_design_axi_uartlite_0_0.vhd" \
-endlib
-makelib xcelium_lib/axi_timer_v2_0_22 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/a141/hdl/axi_timer_v2_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_axi_timer_0_0/sim/mb_design_axi_timer_0_0.vhd" \
-endlib
-makelib xcelium_lib/fit_timer_v2_0_10 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/e81b/hdl/fit_timer_v2_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_fit_timer_0_0/sim/mb_design_fit_timer_0_0.vhd" \
  "../../../bd/mb_design/sim/mb_design.vhd" \
-endlib
-makelib xcelium_lib/emc_common_v3_0_5 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/ea80/hdl/emc_common_v3_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/axi_emc_v3_0_20 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/d985/hdl/axi_emc_v3_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_axi_emc_0_0/sim/mb_design_axi_emc_0_0.vhd" \
-endlib
-makelib xcelium_lib/microblaze_v11_0_2 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/f871/hdl/microblaze_v11_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_microblaze_0_1/sim/mb_design_microblaze_0_1.vhd" \
-endlib
-makelib xcelium_lib/lmb_v10_v3_0_10 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/2e88/hdl/lmb_v10_v3_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_dlmb_v10_1/sim/mb_design_dlmb_v10_1.vhd" \
  "../../../bd/mb_design/ip/mb_design_ilmb_v10_1/sim/mb_design_ilmb_v10_1.vhd" \
-endlib
-makelib xcelium_lib/lmb_bram_if_cntlr_v4_0_17 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/db6f/hdl/lmb_bram_if_cntlr_v4_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_dlmb_bram_if_cntlr_1/sim/mb_design_dlmb_bram_if_cntlr_1.vhd" \
  "../../../bd/mb_design/ip/mb_design_ilmb_bram_if_cntlr_1/sim/mb_design_ilmb_bram_if_cntlr_1.vhd" \
-endlib
-makelib xcelium_lib/blk_mem_gen_v8_4_4 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/2985/simulation/blk_mem_gen_v8_4.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_lmb_bram_1/sim/mb_design_lmb_bram_1.v" \
-endlib
-makelib xcelium_lib/lib_fifo_v1_0_14 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/a5cb/hdl/lib_fifo_v1_0_rfs.vhd" \
-endlib
-makelib xcelium_lib/axi_datamover_v5_1_22 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/1e40/hdl/axi_datamover_v5_1_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/axi_sg_v4_1_13 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/4919/hdl/axi_sg_v4_1_rfs.vhd" \
-endlib
-makelib xcelium_lib/axi_dma_v7_1_21 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/ec2a/hdl/axi_dma_v7_1_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_axi_dma_0_0/sim/mb_design_axi_dma_0_0.vhd" \
-endlib
-makelib xcelium_lib/axis_infrastructure_v1_1_0 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/8713/hdl/axis_infrastructure_v1_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/axis_data_fifo_v2_0_2 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/3341/hdl/axis_data_fifo_v2_0_vl_rfs.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_axis_data_fifo_0_0/sim/mb_design_axis_data_fifo_0_0.v" \
-endlib
-makelib xcelium_lib/axi_protocol_converter_v2_1_20 \
  "../../../../DmaDemo.srcs/sources_1/bd/mb_design/ipshared/c4a6/hdl/axi_protocol_converter_v2_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../bd/mb_design/ip/mb_design_auto_pc_8/sim/mb_design_auto_pc_8.v" \
  "../../../bd/mb_design/ip/mb_design_auto_pc_0/sim/mb_design_auto_pc_0.v" \
  "../../../bd/mb_design/ip/mb_design_auto_pc_1/sim/mb_design_auto_pc_1.v" \
  "../../../bd/mb_design/ip/mb_design_auto_pc_2/sim/mb_design_auto_pc_2.v" \
  "../../../bd/mb_design/ip/mb_design_auto_pc_3/sim/mb_design_auto_pc_3.v" \
  "../../../bd/mb_design/ip/mb_design_auto_pc_4/sim/mb_design_auto_pc_4.v" \
  "../../../bd/mb_design/ip/mb_design_auto_pc_5/sim/mb_design_auto_pc_5.v" \
  "../../../bd/mb_design/ip/mb_design_auto_pc_6/sim/mb_design_auto_pc_6.v" \
  "../../../bd/mb_design/ip/mb_design_auto_pc_7/sim/mb_design_auto_pc_7.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  glbl.v
-endlib

max_stars_repo_name: catarinaacsilva/vivado-xilinx-tutorials


text:
C     Hello World in Fortran

      PROGRAM HELLO
      WRITE (*,100)
      STOP
  100 FORMAT (' Hello World! ' /)
      END

max_stars_repo_path: src/Fortran/Hello Wolrd.for

max_issues_repo_path: src/Fortran/Hello Wolrd.for

max_forks_repo_path: src/Fortran/Hello Wolrd.for


text:
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine basefile  --  get base prefix from a filename  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "basefile" extracts from an input filename the portion
c     consisting of any directory name and the base filename
c
c
      subroutine basefile (string)
      implicit none
      include 'ascii.i'
      include 'files.i'
      integer i,k,trimtext
      character*1 letter
      character*120 string
c
c
c     store the input filename and find its full length
c
      filename = string
      leng = trimtext (string)
c
c     count the number of characters prior to any extension
c
      k = leng
      do i = 1, leng
         letter = string(i:i)
         if (letter .eq. '/')  k = leng
c        if (letter .eq. '\')  k = leng
         if (ichar(letter) .eq. backslash)  k = leng
         if (letter .eq. ']')  k = leng
         if (letter .eq. ':')  k = leng
         if (letter .eq. '~')  k = leng
         if (letter .eq. '.')  k = i - 1
      end do
      leng = min(leng,k)
c
c     find the length of any directory name prefix
c
      k = 0
      do i = leng, 1, -1
         letter = string(i:i)
         if (letter .eq. '/')  k = i
c        if (letter .eq. '\')  k = i
         if (ichar(letter) .eq. backslash)  k = i
         if (letter .eq. ']')  k = i
         if (letter .eq. ':')  k = i
         if (letter .eq. '~')  k = i
c        if (letter .eq. '.')  k = i
         if (k .ne. 0)  goto 10
      end do
   10 continue
      ldir = k
c
c     read and store the keywords from the keyfile
c
      call getkey
c
c     get the information level and output style
c
      call control
      return
      end

max_stars_repo_name: htna/HCsbLib

max_issues_repo_name: htna/HCsbLib

max_forks_repo_name: htna/HCsbLib


text:
create buffer 1024 allot        \ create a buffer

12345678 buffer 10 itoa drop    \ itoa() translates the number into a string
buffer puts                     \ show the string

12345678 buffer 16 itoa drop    \ itoa() translates the number into a string but in hexdecimal
buffer puts                     \ show the string

123 456 buffer 10 ltoa drop
buffer puts

bye

max_stars_repo_name: hcchengithub/weforth

max_issues_repo_name: hcchengithub/weforth

max_forks_repo_name: hcchengithub/weforth


text:
module ale_variables
implicit none
save

real(8) landa_over_mu
integer kinner
integer kouter
end module ale_variables

max_stars_repo_name: biofluids/IFEM-archive

max_issues_repo_name: biofluids/IFEM-archive

max_forks_repo_name: biofluids/IFEM-archive