text:
earthly is a Music Scene band formed in Davis through the collaboration of Josiah Of the Future & Leif Bauer, with Alex Seratti on Drums.  Occasionally Kevin Deacon plays Trumpet at live shows.  They have a http://earthly.bandcamp.com/ website.

Recordings include demo, 3arthly demo 2wo, & demo Remaster

(Remaster by Matigus)

earthly has played at Delta of Venus, Armadillo Music, and International House, as well as all over the streets of Davis.

Leif & Josiah met at the Little Prague Open Mic in 2009(?) and have played together previously as Raging Squirrels.

They currently play shows all over Davis, CA.

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
! Copyright (C) 2015-2017, Simone Marsili
! All rights reserved.
! License: BSD 3 clause

module sample_command_line
  use kinds
  use constants
  implicit none
  private
  public :: command_line_read

contains

  subroutine command_line_read(uchk,rseed,beta,istart,mc_nsweeps,nupdate,&
                               prefix,error_code)
    use units, only: units_open,units_open_unf
    use arguments, only: read_opt,read_opt_arg
    integer,                    intent(inout) :: uchk
    integer,                    intent(inout) :: rseed
    real(kflt),                 intent(inout) :: beta
    integer,                    intent(inout) :: istart
    integer,                    intent(inout) :: mc_nsweeps
    integer,                    intent(inout) :: nupdate
    character(len=*),           intent(out) :: prefix
    integer,                    intent(out)   :: error_code
    integer                         :: err
    character(len=long_string_size) :: chk_file
    character(len=long_string_size) :: cmd
    integer                         :: nargs
    character(len=long_string_size) :: arg
    integer                         :: iarg
    logical                         :: file_exists

    error_code = 0

    call get_command(cmd)
    nargs = command_argument_count()

    if (nargs == 0) then
       ! no args: print syntax and stop
       write(0,100)
       error_code = 1
       return
    end if

    ! default
    chk_file = ''

    iarg = 0
    args_loop: do while(iarg < nargs)
       iarg = iarg + 1
       call read_opt(iarg,nargs,arg,err)
       select case(trim(arg))
       case('-h','--help')
          ! print help and exit
          write(0,100)
          error_code = 1
          return
       case('-c','--chk')
          ! chk file
          iarg = iarg + 1
          call read_opt_arg(iarg,nargs,chk_file,err)
          if (err == 1) then
             write(0,*) 'ERROR ! missing argument: '//trim(arg)//' <filename>'
             error_code = 1
             return
          end if
       case('-t','--temp')
          iarg = iarg + 1
          call read_opt_arg(iarg,nargs,beta,err)
          if ( beta < 0.0) then
             write(0,*) 'ERROR ! check beta'
             error_code = 1
             return
          end if
          beta = 1.0_kflt / beta
       case('-n','--nsweeps')
          iarg = iarg + 1
          call read_opt_arg(iarg,nargs,mc_nsweeps,err)
          if ( err/= 0 ) then
             write(0,*) 'ERROR ! check nsweeps'
             error_code = 1
             return
          end if
       case('--seed')
          iarg = iarg + 1
          call read_opt_arg(iarg,nargs,rseed,err)
          if ( err/= 0 ) then
             write(0,*) 'ERROR ! check seed'
             error_code = 1
             return
          end if
       case('-u','--nupdate')
          iarg = iarg + 1
          call read_opt_arg(iarg,nargs,nupdate,err)
          if ( err/= 0 ) then
             write(0,*) 'ERROR ! check nupdate'
             error_code = 1
             return
          end if
       case('--start')
          iarg = iarg + 1
          call read_opt_arg(iarg,nargs,istart,err)
          if ( err/= 0 ) then
             write(0,*) 'ERROR ! check --start argument'
             error_code = 1
             return
          end if
       case('--prefix')
          ! prefix
          iarg = iarg + 1
          call read_opt_arg(iarg,nargs,prefix,err)
          if (err == 1) then
             write(0,*) 'ERROR ! missing argument: '//trim(arg)//' <prefix>'
             error_code = 1
             return
          end if
       case default
          write(0,*) 'ERROR ! invalid option '//trim(arg)
          error_code = 1
          return
       end select
    end do args_loop

    if ( chk_file /= "" ) then
       inquire( file = chk_file, exist = file_exists )
       if ( .not. file_exists ) then
          write(0,*) 'ERROR ! cannot access '//trim(chk_file)
          error_code = 1
          return
       end if
       call units_open_unf(chk_file,'old',uchk,err)
       if( err /= 0 ) then
          write(0,*) 'ERROR ! error opening file '//trim(chk_file)
          error_code = 1
          return
       end if
    else
       write(0,*) 'ERROR ! a chk file is needed'
       error_code = 1
       return
    end if

    if (istart < 0) then
       write(0,*) "ERROR ! index for starting point cant be < 0"
       error_code = 1
       return
    end if

100 format(&
         'elss-sample (elss v0.5)                                           '/&
         '                                                                  '/&
         'Usage:                                                            '/&
         '    elss-sample [options] -c <chk_file>                           '/&
         '                                                                  '/&
         'Description:                                                      '/&
         '    Simulate a trajectory in "sequence" space using the parameters'/&
         '    from checkpoint file <chk_file>. The unformatted checkpoint   '/&
         '    file can be generated using the elss-pchk tool from a set of  '/&
         '    user-defined parameters, or as elss-learn output.             '/&
         '                                                                  '/&
         'Required:                                                         '/&
         '-c, --chk <chk_file>                                              '/&
         '    Read the parameters of the model from checkpoint file.        '/&
         '                                                                  '/&
         'Options:                                                          '/&
         '-h, --help                                                        '/&
         '    Display this help and exit.                                   '/&
         '                                                                  '/&
         '--prefix <str>                                                    '/&
         '    Prefix of output files.                                       '/&
         '                                                                  '/&
         '--start <i>, integer                                              '/&
         '    Use the <i>-th sample in <chk_file> as starting point.        '/&
         '    (indexing starts from zero)                                   '/&
         '    [default: 0]                                                  '/&
         '                                                                  '/&
         '-n, --nsweeps <n>, integer                                        '/&
         '    Simulate <n> MC sweeps.                                       '/&
         '    [default: 1000]                                               '/&
         '                                                                  '/&
         '-u, --nupdate <n>, integer                                        '/&
         '    Update model averages every <n> sweeps.                       '/&
         '    [default: 10]                                                 '/&
         '                                                                  '/&
         '--seed <seed>, integer                                            '/&
         '    Seed for the pseudo-random number generator.                  '/&
         '    If == 0, the seed is generated from system clock.             '/&
         '    [default: 0]                                                  '/&
         '                                                                  '/&
         'Examples:                                                         '/&
         '                                                                  '/)

  end subroutine command_line_read

end module sample_command_line

max_stars_repo_name: simomarsili/elss

max_issues_repo_name: simomarsili/elss

max_forks_repo_name: simomarsili/elss


! !---------------------------------------------------------------------!
!     function get_keyword_string(unit,keyword,status)
!       implicit none
!       integer :: unit,status
!       character (len=30) keyword,comment,error_description
!       character (len=100) get_keyword_string

!       call ftgkyd(unit, keyword, get_keyword_string, comment, status)

!       if(status .ne. 0) then
!          call ftgerr(status,error_description)
!          if (status .ne. 0) write(*,*) '!! ATTENTION !! ', error_description
!          write(*,'(A,A,A)') '   The keyword: ', trim(keyword),' does not match any of the keyword in the extension, try another one'
!          read(*,*) keyword
!          status = 0
!          call ftgkyd(unit,keyword,get_keyword_string,comment,status)
!          if(status .ne. 0) then
!             call ftgerr(status,error_description)
!             if (status .ne. 0) write(*,*) '!! ATTENTION !! ', error_description
!             write(*,*) '   Neither this one, EXIT...'
!          endif
!       endif
!     end function get_keyword_string
! !---------------------------------------------------------------------!

!---------------------------------------------------------------------!
    function get_keyword_double(unit,keyword,status)
      implicit none
      integer :: unit,status
      character (len=30) keyword,comment,error_description
      double precision get_keyword_double

      call ftgkyd(unit, keyword, get_keyword_double, comment, status)

      if(status .ne. 0) then
         call ftgerr(status,error_description)
         if (status .ne. 0) write(*,*) '!! ATTENTION !! ', error_description
         write(*,'(A,A,A)') '   The keyword: ', trim(keyword),' does not match any of the keyword in the extension, try another one'
         read(*,*) keyword
         status = 0
         call ftgkyd(unit,keyword,get_keyword_double,comment,status)
         if(status .ne. 0) then
            call ftgerr(status,error_description)
            if (status .ne. 0) write(*,*) '!! ATTENTION !! ', error_description
            write(*,*) '   Neither this one, EXIT...'
         endif
      endif
    end function get_keyword_double
!---------------------------------------------------------------------!


program use_ext
use constants, only: get_pi

implicit none (type, external)

print *,'using submodule, pi=',get_pi()

end program


! { dg-do run }
!
! PR 59654: [4.8/4.9 Regression] [OOP] Broken function table with complex OO use case
!
! Contributed by Thomas Clune <Thomas.L.Clune@nasa.gov>

module TestResult_mod
  implicit none

  type TestResult
    integer :: numRun = 0
  contains
    procedure :: run
    procedure, nopass :: getNumRun
  end type

contains

  subroutine run (this)
    class (TestResult) :: this
    this%numRun = this%numRun + 1
  end subroutine

  subroutine getNumRun()
   end subroutine

end module

module BaseTestRunner_mod
  implicit none

  type :: BaseTestRunner
  contains
    procedure, nopass :: norun
  end type

contains

  function norun () result(result)
    use TestResult_mod, only: TestResult
    type (TestResult) :: result
  end function

end module

module TestRunner_mod
  use BaseTestRunner_mod, only: BaseTestRunner
  implicit none
end module

program main
  use TestRunner_mod, only: BaseTestRunner
  use TestResult_mod, only: TestResult
  implicit none

  type (TestResult) :: result

  call runtest (result)

contains

  subroutine runtest (result)
    use TestResult_mod, only: TestResult
    class (TestResult) :: result
    call result%run()
    if (result%numRun /= 1) call abort()
  end subroutine

end

! { dg-final { cleanup-modules "TestResult_mod BaseTestRunner_mod TestRunner_mod" } }


!***********************************/
!	Name:VenkatakrishnanリミッターのΔmax，Δminを求めるプログラム
!	Alias:FindVariation
!	Description:(隣接セルの基本変数)-(自セルの基本変数)を計算して，変数ごとに最小値と最大値を評価する
!	Type:CellCenter
!	Input:CC%PrimitiveVariable
!	Output:CC%VariationOfVariable
!	Note:法線ベクトルについての考慮は式自体に内包してあるのでいらない
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2018.01.11
!	Other:
!***********************************/
subroutine FindVariation(Geom,CC)
    use StructVar_Mod
    use LoopVar_Mod
    use ConstantVar_Mod, only:CoreNumberOfCPU
    implicit none
    type(Geometry), intent(in) :: Geom
    type(CellCenter), intent(inout) :: CC
    double precision, allocatable :: Variation(:,:)
!隣接セルにおける最大変分と最小変分を検索(1次元の場合は左右の変動量の多い方を見つけるだけ)
!call FindVariation!(Geom,CC)
    allocate(Variation(Geom%Dimension+2, 2*Geom%Dimension)) !各変数,xyzの両側
    nullify(iCX,iCY,iCZ,iFX,iFY,iFZ,iVar)
    iVar => iVariable
    iCX => iCenterX
    iCY => iCenterY
    iCZ => iCenterZ

        if(Geom%Dimension == 1) then
            do iCenterX = 1, Geom%CellNumber(1)
                Variation(:,1) = CC%PrimitiveVariable(:,iCX-1,1,1) - CC%PrimitiveVariable(:,iCX,1,1)
                Variation(:,2) = CC%PrimitiveVariable(:,iCX+1,1,1) - CC%PrimitiveVariable(:,iCX,1,1)
                CC%VariationOfVariable(1,:,iCX,1,1) = maxval(Variation,2)
                CC%VariationOfVariable(2,:,iCX,1,1) = minval(Variation,2)
            end do

        else if(Geom%Dimension == 2) then
            !全実セルについてループ
!!$omp parallel num_threads(CoreNumberOfCPU),shared(Geom,CC),firstprivate(iCenterX,iCenterY,Variation)
!!$omp do
            do iCenterY = 1, Geom%CellNumber(2)
                do iCenterX = 1, Geom%CellNumber(1)
                    Variation(:,1) = CC%PrimitiveVariable(:,iCenterX-1,iCenterY,1) - CC%PrimitiveVariable(:,iCenterX,iCenterY,1)
                    Variation(:,2) = CC%PrimitiveVariable(:,iCenterX+1,iCenterY,1) - CC%PrimitiveVariable(:,iCenterX,iCenterY,1)
                    Variation(:,3) = CC%PrimitiveVariable(:,iCenterX,iCenterY-1,1) - CC%PrimitiveVariable(:,iCenterX,iCenterY,1)
                    Variation(:,4) = CC%PrimitiveVariable(:,iCenterX,iCenterY+1,1) - CC%PrimitiveVariable(:,iCenterX,iCenterY,1)
                    CC%VariationOfVariable(1,:,iCenterX,iCenterY,1) = maxval(Variation,2)
                    CC%VariationOfVariable(2,:,iCenterX,iCenterY,1) = minval(Variation,2)
                end do
            end do
!!$omp end do
!!$omp end parallel

        else if(Geom%Dimension == 3) then
            do iCenterZ = 1, Geom%CellNumber(3)
                do iCenterY = 1, Geom%CellNumber(2)
                    do iCenterX = 1, Geom%CellNumber(1)
                        Variation(:,1) = CC%PrimitiveVariable(:,iCX-1,iCY,iCZ) - CC%PrimitiveVariable(:,iCX,iCY,iCZ)
                        Variation(:,2) = CC%PrimitiveVariable(:,iCX+1,iCY,iCZ) - CC%PrimitiveVariable(:,iCX,iCY,iCZ)
                        Variation(:,3) = CC%PrimitiveVariable(:,iCX,iCY-1,iCZ) - CC%PrimitiveVariable(:,iCX,iCY,iCZ)
                        Variation(:,4) = CC%PrimitiveVariable(:,iCX,iCY+1,iCZ) - CC%PrimitiveVariable(:,iCX,iCY,iCZ)
                        Variation(:,5) = CC%PrimitiveVariable(:,iCX,iCY,iCZ-1) - CC%PrimitiveVariable(:,iCX,iCY,iCZ)
                        Variation(:,6) = CC%PrimitiveVariable(:,iCX,iCY,iCZ+1) - CC%PrimitiveVariable(:,iCX,iCY,iCZ)
                        CC%VariationOfVariable(1,:,iCX,iCY,1) = maxval(Variation,2)
                        CC%VariationOfVariable(2,:,iCX,iCY,1) = minval(Variation,2)
                    end do
                end do
            end do

        end if
        deallocate(Variation)
    return
end subroutine FindVariation


      subroutine calsoft_control

      use sd_channel_module
      use hru_lte_module
      use maximum_data_module
      use calibration_data_module
      use time_module
      use basin_module
      use hru_module, only : hru
      use hydrograph_module

      implicit none

      integer :: ireg        !none      |counter
      integer :: ilum        !none      |counter
      integer :: icvmax      !          |
      integer :: icond_sum   !          |
      integer :: ihru        !none      |counter
      integer :: isdh        !none      |counter
      integer :: idb         !          |
      integer :: iord        !none      |counter
      integer :: isdc        !none      |counter
      integer :: nvar        !none      |number of plant cal variables (1=lai_pot, 2=harv_idx)
      real :: cond1          !          |
      real :: cond2          !          |

      pco = pco_init
      pco%wb_bsn%a = "y"
      !pco%wb_bsn%y = "y"
      !pco%wb_bsn%m = "y"
      !pco%wb_bsn%d = "y"
      !pco%wb_hru%a = "y"
      !pco%sd_chan%a = "y"

      !calibrate hydrology for hru
      if (cal_codes%hyd_hru == "y") then
        !call calsoft_hyd
        call calsoft_hyd_bfr
        !print calibrated hydrology for hru_lte
		do ireg = 1, db_mx%lsu_reg
           do ilum = 1, region(ireg)%nlum
            lscal(ireg)%lum(ilum)%meas%srr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%srr
            lscal(ireg)%lum(ilum)%meas%lfr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%lfr
            lscal(ireg)%lum(ilum)%meas%pcr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%pcr
            lscal(ireg)%lum(ilum)%meas%etr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%etr
            lscal(ireg)%lum(ilum)%meas%tfr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%tfr

            !write (5000,500) lscal(ireg)%lum(ilum)%name, lscal(ireg)%lum(ilum)%ha, lscal(ireg)%lum(ilum)%nbyr,  &
            !        lscal(ireg)%lum(ilum)%precip_aa_sav, lscal(ireg)%lum(ilum)%meas, lscal(ireg)%lum(ilum)%aa,  &
            !        lscal(ireg)%lum(ilum)%prm
		  end do
        end do

      end if

      !calibrate hydrology for hru_lte
      if (cal_codes%hyd_hrul == "y") then
        call caltsoft_hyd
        !print calibrated hydrology for hru_lte
		do ireg = 1, db_mx%lsu_reg
		  do ilum = 1, lscalt(ireg)%lum_num
            lscalt(ireg)%lum(ilum)%meas%srr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%srr
            lscalt(ireg)%lum(ilum)%meas%lfr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%lfr
            lscalt(ireg)%lum(ilum)%meas%pcr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%pcr
            lscalt(ireg)%lum(ilum)%meas%etr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%etr
            lscalt(ireg)%lum(ilum)%meas%tfr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%tfr

            !write (5000,500) lscalt(ireg)%name, lscalt(ireg)%lum(ilum)%ha, lscalt(ireg)%lum(ilum)%nbyr,           &
            !        lscalt(ireg)%lum(ilum)%precip_aa_sav, lscalt(ireg)%lum(ilum)%meas, lscalt(ireg)%lum(ilum)%aa, &
            !        lscalt(ireg)%lum(ilum)%prm
		  end do
        end do

	    do isdh = 1, sp_ob%hru_lte
	      idb = hlt(isdh)%props
		  write (4999,*) hlt(isdh)%name, hlt_db(idb)%dakm2, hlt(isdh)%cn2, hlt(isdh)%cn3_swf, hlt_db(idb)%tc,       &
		    hlt_db(idb)%soildep, hlt(isdh)%perco, hlt_db(isdh)%slope, hlt_db(idb)%slopelen,                         &
		    hlt(isdh)%etco, hlt_db(idb)%sy, hlt_db(idb)%abf, hlt(idb)%revapc,                                       &
		    hlt_db(idb)%percc, hlt_db(idb)%sw, hlt_db(idb)%gw, hlt_db(idb)%gwflow,                                  &
		    hlt_db(idb)%gwdeep, hlt_db(idb)%snow, hlt_db(idb)%xlat, hlt_db(idb)%text,                               &
		    hlt_db(idb)%tropical, hlt_db(idb)%igrow1, hlt_db(idb)%igrow2, hlt_db(idb)%plant, hlt(isdh)%stress,      &
		    hlt_db(idb)%ipet, hlt_db(idb)%irr, hlt_db(idb)%irrsrc, hlt_db(idb)%tdrain,                              &
            hlt_db(idb)%uslek, hlt_db(idb)%uslec, hlt_db(idb)%uslep, hlt_db(idb)%uslels
	    end do
      end if

      !calibrate plant growth
      if (cal_codes%plt == "y") then
        call calsoft_plant
      end if

      !calibrate sediment yield from uplands (hru"s)
      if (cal_codes%sed == "y") then
        call calsoft_sed
      end if

	  !  do isdc = 1, sp_ob%chandeg
	  !    idb = sd_ch(isdc)%props
		!  write (4999,*) sd_chd(idb)%name, sd_chd(idb)%order, sd_chd(idb)%chw,          &
      !        sd_chd(idb)%chd, sd_chd(idb)%chs, sd_chd(idb)%chl, sd_chd(idb)%chn, sd_chd(idb)%chk,              &
      !        sd_ch(isdc)%cherod, sd_ch(isdc)%cov, sd_chd(idb)%hc_cov, sd_chd(idb)%chseq, sd_chd(idb)%d50,      &
      !        sd_chd(idb)%clay, sd_chd(idb)%bd, sd_chd(idb)%chss, sd_chd(idb)%bedldcoef, sd_chd(idb)%tc,        &
      !        sd_ch(isdc)%shear_bnk, sd_ch(isdc)%hc_erod, sd_chd(idb)%hc_hgt, sd_chd(idb)%hc_ini
	  !  end do

      !calibrate channel sediment
      if (cal_codes%chsed == "y") then
        call calsoft_chsed
      end if

      if (cal_codes%chsed == "y") then
        do ireg = 1, db_mx%ch_reg
          do iord = 1, chcal(ireg)%ord_num
            !! channel sediment parms
            if (chcal(ireg)%ord(iord)%aa%chw > 1.e-6) icvmax = icvmax + 1
          end do
        end do
      end if

      !! write output to hydrology-cal.hyd
      if (cal_codes%hyd_hru == "y") then
        write (5001,*) " hydrology-cal.hyd developed from soft data calibration"
        write (5001,*) " NAME LAT_TTIME LAT_SED CAN_MAX  ESCO  EPCO ORGN_ENRICH ORGP_ENRICH CN3_SWF &
                                               BIO_MIX PERCO LAT_ORGN LAT_ORGP HARG_PET LATQ_CO"
        do ihru = 1, sp_ob%hru
          write (5001,*) hru(ihru)%hyd
        end do
      end if

      !! plant parms
      if (cal_codes%plt == "y") then
        call pl_write_parms_cal
      end if      ! plant parms

      if (cal_codes%chsed == "y") then
        do ireg = 1, db_mx%ch_reg
          do iord = 1, chcal(ireg)%ord_num
            !! channel sediment parms
            if (chcal(ireg)%ord(iord)%aa%chw > 1.e-6) icvmax = icvmax + 1
          end do
        end do
      end if

      !! channel sediment parms
      if (cal_codes%chsed == "y") then
        do ireg = 1, db_mx%ch_reg
          do iord = 1, chcal(ireg)%ord_num
            if (abs(chcal(ireg)%ord(iord)%aa%chw) > 1.e-6) then
              write (5000,503) ch_prms(1)%name, ch_prms(1)%chg_typ, chcal(ireg)%ord(iord)%prm%erod,          &
              "     0      0      0      0      0      0      0      0      0"
            end if
          end do
        end do
      end if      ! channel sediment parms

  500 format (a16,f12.3,i12,f12.3,2(1x,a16,10f12.3),10f12.3)
  503 format (2a16,f12.5,a)

      return
      end subroutine calsoft_control


text: #redirect Bicycle Rides


text:
great(a1,t1).
great(f1,q1).
great(hh1,p1).
great(a1,ee1).
great(dd1,v1).
great(ee1,bb1).
great(kk1,b1).
great(j1,dd1).
great(g1,cc1).
great(l1,n1).
great(k1,x1).
great(a1,o1).
great(jj1,s1).
great(g1,y1).
great(d1,i1).
great(c1,k1).
great(j1,w1).
great(u1,b1).
great(f1,p1).
great(v1,t1).
great(q1,cc1).
great(y1,ll1).
great(e1,s1).
great(j1,p1).
great(k1,p1).
great(h1,a1).
great(s1,w1).
great(w1,m1).
great(h1,s1).
great(d1,ff1).
great(d1,t1).
great(g1,jj1).
great(cc1,x1).
great(q1,dd1).
great(u1,w1).
great(c1,o1).
great(q1,y1).
great(jj1,v1).
great(d1,k1).
great(j1,s1).
great(h1,z1).
great(e1,y1).
great(r1,v1).
great(c1,aa1).
great(e1,u1).
great(z1,ll1).
great(d1,e1).
great(aa1,j1).
great(ll1,hh1).
great(aa1,d1).
great(n1,k1).
great(s1,dd1).
great(p1,ee1).
great(n1,dd1).
great(m1,dd1).
great(m1,x1).
great(g1,e1).
great(x1,g1).
great(r1,hh1).
great(ee1,v1).
great(p1,s1).
great(dd1,cc1).
great(t1,z1).
great(t1,hh1).
great(j1,g1).
great(dd1,g1).
great(r1,h1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


!
!  Copyright 2019-2020 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
MODULE init_communicator
  implicit none

CONTAINS

!===================================================================================================================================

subroutine init_communicator_dft(comm,info)
  use salmon_global, only: process_allocation
  use structures, only: s_parallel_info
  use communication, only: comm_create_group, comm_get_groupinfo, &
                           comm_is_root, comm_summation, comm_create_group_byid
  implicit none
  integer             ,intent(in) :: comm
  type(s_parallel_info)           :: info
  !
  integer :: myrank,nproc
  integer :: nproc_k,nproc_ob
  integer :: nproc_d_o(3)
  integer :: i1,i2,i3,i4,i5,ix,iy,iz,nl
  integer,allocatable :: iranklists(:)

#ifdef __FUJITSU
  integer :: iret
#endif

  call comm_get_groupinfo(comm, myrank, nproc)

  nproc_k   = info%npk
  nproc_ob  = info%nporbital
  nproc_d_o = info%nprgrid

  allocate(iranklists(nproc))

! info
  info%icomm_rko = comm
  info%id_rko    = myrank
  info%isize_rko = nproc

  allocate(info%imap(0:nproc_d_o(1)-1, &
                     0:nproc_d_o(2)-1, &
                     0:nproc_d_o(3)-1, &
                     0:nproc_ob-1, &
                     0:nproc_k-1))

! communicator r,o,k,ro,ko
#ifdef __FUJITSU
  call tofu_network_oriented_mapping(iret)
  if (iret < 0) then
    if (comm_is_root(info%id_rko)) then
      print *, 'Requested process shape does not match Tofu network shape.'
      print *, 'We fallback to usual mapping...'
    end if
#endif
    nl = -1
    if (process_allocation == 'grid_sequential') then
      do i5=0,nproc_k-1
      do i4=0,nproc_ob-1
      do i3=0,nproc_d_o(3)-1
      do i2=0,nproc_d_o(2)-1
      do i1=0,nproc_d_o(1)-1
        nl = nl + 1
        info%imap(i1,i2,i3,i4,i5) = nl
        if (nl == myrank) then
          info%iaddress = [i1,i2,i3,i4,i5]
        end if
      end do
      end do
      end do
      end do
      end do
    else if (process_allocation == 'orbital_sequential') then
      do i3=0,nproc_d_o(3)-1
      do i2=0,nproc_d_o(2)-1
      do i1=0,nproc_d_o(1)-1
      do i5=0,nproc_k-1
      do i4=0,nproc_ob-1
        nl = nl + 1
        info%imap(i1,i2,i3,i4,i5) = nl
        if (nl == myrank) then
          info%iaddress = [i1,i2,i3,i4,i5]
        end if
      end do
      end do
      end do
      end do
      end do
    else
      stop 'undefined: process_allocation'
    end if

    if (nl /= info%isize_rko-1) &
      stop '[FATAL ERROR] init_communicator_dft'
#ifdef __FUJITSU
  end if
#endif

  ! icomm_r
  i5 = info%iaddress(5)
  i4 = info%iaddress(4)
  nl = 0
  do i3=0,nproc_d_o(3)-1
  do i2=0,nproc_d_o(2)-1
  do i1=0,nproc_d_o(1)-1
    nl = nl + 1
    iranklists(nl) = info%imap(i1,i2,i3,i4,i5)
  end do
  end do
  end do

  info%icomm_r = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_r, info%id_r, info%isize_r)

  ! icomm_o
  i5 = info%iaddress(5)
  i3 = info%iaddress(3)
  i2 = info%iaddress(2)
  i1 = info%iaddress(1)
  nl = 0
  do i4=0,nproc_ob-1
    nl = nl + 1
    iranklists(nl) = info%imap(i1,i2,i3,i4,i5)
  end do

  info%icomm_o = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_o, info%id_o, info%isize_o)

  ! icomm_k
  i4 = info%iaddress(4)
  i3 = info%iaddress(3)
  i2 = info%iaddress(2)
  i1 = info%iaddress(1)
  nl = 0
  do i5=0,nproc_k-1
    nl = nl + 1
    iranklists(nl) = info%imap(i1,i2,i3,i4,i5)
  end do

  info%icomm_k = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_k, info%id_k, info%isize_k)

  ! icomm_ro
  i5 = info%iaddress(5)
  nl = 0
  do i4=0,nproc_ob-1
  do i3=0,nproc_d_o(3)-1
  do i2=0,nproc_d_o(2)-1
  do i1=0,nproc_d_o(1)-1
    nl = nl + 1
    iranklists(nl) = info%imap(i1,i2,i3,i4,i5)
  end do
  end do
  end do
  end do

  info%icomm_ro = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_ro, info%id_ro, info%isize_ro)

  ! icomm_ko
  i3 = info%iaddress(3)
  i2 = info%iaddress(2)
  i1 = info%iaddress(1)
  nl = 0
  do i5=0,nproc_k-1
  do i4=0,nproc_ob-1
    nl = nl + 1
    iranklists(nl) = info%imap(i1,i2,i3,i4,i5)
  end do
  end do

  info%icomm_ko = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_ko, info%id_ko, info%isize_ko)

  i5 = info%iaddress(5)
  i4 = info%iaddress(4)

! x-dir summation
  iz = info%iaddress(3)
  iy = info%iaddress(2)
  nl = 0
  do ix=0,nproc_d_o(1)-1
    nl = nl + 1
    iranklists(nl) = info%imap(ix,iy,iz,i4,i5)
  end do
  info%icomm_x = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_x, info%id_x, info%isize_x)

! y-dir summation
  iz = info%iaddress(3)
  ix = info%iaddress(1)
  nl = 0
  do iy=0,nproc_d_o(2)-1
    nl = nl + 1
    iranklists(nl) = info%imap(ix,iy,iz,i4,i5)
  end do
  info%icomm_y = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_y, info%id_y, info%isize_y)

! z-dir summation
  iy = info%iaddress(2)
  ix = info%iaddress(1)
  nl = 0
  do iz=0,nproc_d_o(3)-1
    nl = nl + 1
    iranklists(nl) = info%imap(ix,iy,iz,i4,i5)
  end do
  info%icomm_z = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_z, info%id_z, info%isize_z)

! xy-dir summation (for singlescale FDTD)
  iz = info%iaddress(3)
  nl = 0
  do iy=0,nproc_d_o(2)-1
  do ix=0,nproc_d_o(1)-1
    nl = nl + 1
    iranklists(nl) = info%imap(ix,iy,iz,i4,i5)
  end do
  end do
  info%icomm_xy = comm_create_group_byid(comm, iranklists(1:nl))
  call comm_get_groupinfo(info%icomm_xy, info%id_xy, info%isize_xy)

#ifdef __FUJITSU
contains
  subroutine tofu_network_oriented_mapping(iret)
    use mpi_ext
    implicit none
    integer,intent(out) :: iret
    integer,parameter :: maxppn = 16
    integer :: n,pw(3)
    integer :: tofu_dim, tofu_shape(3), nprocs_per_node, icoords(3)
    integer :: pshape(3), iaddress(5)
    integer :: iranks(maxppn), outppn
    integer :: ierr

    iret = -1

    call FJMPI_Topology_get_dimension(tofu_dim, ierr)
    if (ierr /= MPI_SUCCESS) &
      stop 'FJMPI_Topology_get_dimension: error'

    call FJMPI_Topology_get_shape(tofu_shape(1), tofu_shape(2), tofu_shape(3), ierr)
    if (ierr /= MPI_SUCCESS) &
      stop 'FJMPI_Topology_get_shape: error'

    call FJMPI_Topology_get_coords(info%icomm_rko, info%id_rko, FJMPI_LOGICAL, tofu_dim, icoords, ierr)
    if (ierr /= MPI_SUCCESS) &
      stop 'FJMPI_Topology_get_coords: error'

    nprocs_per_node = info%isize_rko / product(tofu_shape(1:tofu_dim))
    if (mod(info%isize_rko, product(tofu_shape(1:tofu_dim))) /= 0) &
      stop 'logical error: calcluate # of process/node'

    call FJMPI_Topology_get_ranks(info%icomm_rko, FJMPI_LOGICAL, icoords, maxppn, outppn, iranks, ierr)
    if (ierr /= MPI_SUCCESS) &
      stop 'FJMPI_Topology_get_ranks: error'
    if (outppn /= nprocs_per_node) &
      stop 'logical error: get # of process/node'

    select case(tofu_dim)

    case default
      if (comm_is_root(info%id_rko)) then
        print *, 'tofu_network_oriented_mapping: unsupported Tofu dimension,', tofu_dim
      end if
      return

    ! 3-dimensional network
    case(3)
      if (comm_is_root(info%id_rko)) then
        print *, '======================================================='
        print *, 'SALMON executes on 3-dimensional Tofu-network system...'
        print *, 'nproc_rgrid      :', nproc_d_o
        print *, 'nproc_ob*nproc_k :', nproc_ob*nproc_k
        print *, 'Tofu shape       :', tofu_shape
        print *, '# of process/node:', nprocs_per_node
        print *, ''
        print *, '[PROCESS MAPPING RULE]'
        print *, '  Requested network shape = (PX, PY, PZ, PW)'
        print *, '  Tofu-network shape      = (TX, TY, TZ)'
        print *, '  Process shape           = (TX*PPN, TY, TZ)'
        print *, ''
        print *, '  (PX, PY, PZ) = nproc_rgrid'
        print *, '  PW           = nproc_ob*nproc_k'
        print *, '  PPN          = # of process/node'
        if (process_allocation == 'grid_sequential') then
          print *, '  PW  = PW1*PW2*PW3'
          print *, '  PW1 = TX*PPN / PX'
          print *, '  PW2 = TY     / PY'
          print *, '  PW3 = TZ     / PZ'
          print *, '  TX  = PX*PW1 / PPN'
          print *, '  TY  = PY*PW2'
          print *, '  TZ  = PZ*PW3'
        else if (process_allocation == 'orbital_sequential') then
          print *, '  PX  = PX1*PX2*PX3'
          print *, '  PX1 = TX*PPN / PW'
          print *, '  PX2 = TY     / PY'
          print *, '  PX3 = TZ     / PZ'
          print *, '  TX  = PW*PX1 / PPN'
          print *, '  TY  = PY*PX2'
          print *, '  TZ  = PZ*PX3'
        end if
      end if

      if (process_allocation == 'grid_sequential') then
        pw(1) = tofu_shape(1) * nprocs_per_node / nproc_d_o(1)
      else if (process_allocation == 'orbital_sequential') then
        pw(1) = tofu_shape(1) * nprocs_per_node / (nproc_ob*nproc_k)
      end if
      pw(2) = tofu_shape(2) / nproc_d_o(2)
      pw(3) = tofu_shape(3) / nproc_d_o(3)

      if (process_allocation == 'grid_sequential') then
        pshape(1:3) = nproc_d_o(1:3) * pw(1:3)
      else if (process_allocation == 'orbital_sequential') then
        pshape(1)   = nproc_ob*nproc_k * pw(1)
        pshape(2:3) = nproc_d_o(2:3) * pw(2:3)
      end if

      if (comm_is_root(info%id_rko)) then
        if (process_allocation == 'grid_sequential') then
          print *, '  (PW1, PW2, PW3) =', pw(1:3)
          print *, '  (PX*PW1, PY*PW2, PZ*PW3) =', pshape(1:3)
        else if (process_allocation == 'orbital_sequential') then
          print *, '  (PX1, PX2, PX3) =', pw(1:3)
          print *, '  (PW*PX1, PY*PX2, PZ*PX3) =', pshape(1:3)
        end if
        print *, '======================================================='
      end if

      if (process_allocation == 'grid_sequential') then
        if (product(pw) /= nproc_ob*nproc_k) then
          if (comm_is_root(info%id_rko)) then
            print *, 'product(PW[1-3]) /= PW'
            print *, '(PW1, PW2, PW3) =', pw
          end if
          return
        end if
      else if (process_allocation == 'orbital_sequential') then
        if (product(pw) /= nproc_d_o(1)) then
          if (comm_is_root(info%id_rko)) then
            print *, 'product(PX[1-3]) /= PX'
            print *, '(PX1, PX2, PX3) =', pw
          end if
          return
        end if
      end if

      info%imap = -1
      nl = -1
      do iz=0,pshape(3)-1
      do iy=0,pshape(2)-1
      do ix=0,pshape(1)-1
        nl = nl + 1

        iaddress(2) = mod(iy, nproc_d_o(2))
        iaddress(3) = mod(iz, nproc_d_o(3))

        if (process_allocation == 'grid_sequential') then
          iaddress(1) = mod(ix, nproc_d_o(1))

          n = ((ix + nproc_d_o(1)) / nproc_d_o(1) - 1) &
            + ((iy + nproc_d_o(2)) / nproc_d_o(2) - 1) * pw(1) &
            + ((iz + nproc_d_o(3)) / nproc_d_o(3) - 1) * pw(1) * pw(2)

          iaddress(4) = mod(n, nproc_ob)
          iaddress(5) = n / nproc_ob
        else if (process_allocation == 'orbital_sequential') then
          n = ((ix + nproc_ob*nproc_k) / nproc_ob*nproc_k - 1) &
            + ((iy + nproc_d_o(2))     / nproc_d_o(2)     - 1) * pw(1) &
            + ((iz + nproc_d_o(3))     / nproc_d_o(3)     - 1) * pw(1) * pw(2)
          iaddress(1) = mod(n, nproc_d_o(1))

          n = mod(ix, nproc_ob*nproc_k)
          iaddress(4) = mod(n, nproc_ob)
          iaddress(5) = n / nproc_ob
        end if

        if (info%imap(iaddress(1),iaddress(2),iaddress(3),iaddress(4),iaddress(5)) /= -1) then
          if (comm_is_root(info%id_rko)) then
            print *, nl,'conflict:',iaddress,' pad =',ix,iy,iz
          end if
          return
        end if

        info%imap(iaddress(1),iaddress(2),iaddress(3),iaddress(4),iaddress(5)) = nl
        if (nl == myrank) then
          info%iaddress = iaddress
        end if
      end do
      end do
      end do

      if (minval(info%imap) < 0 .or. maxval(info%imap) >= info%isize_rko) then
        if (comm_is_root(info%id_rko)) then
          print *, 'tofu_network_oriented_mapping: logical error.'
        end if
        return
      end if

      if (nl /= info%isize_rko-1) then
        if (comm_is_root(info%id_rko)) then
          print *, 'tofu_network_oriented_mapping: Tofu process mapping.'
        end if
        return
      end if

    end select

    iret = 0
    return
  end subroutine tofu_network_oriented_mapping
#endif
end subroutine init_communicator_dft

END MODULE init_communicator


text:
*+ graphic_open

       subroutine graphic_open( defn, s )
C      ----------------------------------
C
C Initialise the graphics device/window for the specified definition
C
C Given:
C  the definition for this graphic
       integer   defn(*)
C
C Updated:
C  error return
       integer   s
C
C The graphics device is initialised for the specified graphic -- if the
C device is not open the the device will be opened for graphical access.
C-

       include '../include/plt_basic_defn.inc'
       include '../include/plt_scratch_defn.inc'
       include '../include/plt_error_defn.inc'

       real*4    x1, x2, y1, y2, xr, yr
       integer   iunit, istat
       integer   pgindev

C check status on entry
       if (s.ne.0) return

C copy information for this graphic structure
       call graphic_copy_graphic( defn, graphic, s )

C check graphic device status
       if (.not.plot_open) then
           istat = pgindev( iunit, plot_device,
     *                     plot_segments, plot_segments,
     *                     plot_list_id(plot_list_selected))
           call pgpap(plot_size,plot_aspect)
           call pgadvance
           call pgpap(plot_size,plot_aspect)
           call pgask( .false. )
         if (istat.ne.1) then
           s = ill_device
         else
           plot_open = .true.
           if (s.eq.0 .and. plot_open) then
             if (plot_aspect.lt.0.01) then
               plot_aspect = 0.7
             endif
             call pgpap(plot_size,plot_aspect)
             call pgadvance
             call pgpap(plot_size,plot_aspect)
           endif
         endif
       elseif (plot_next) then
         call pgpap(plot_size,plot_aspect)
         call pgadvance
         call pgpap(plot_size,plot_aspect)
         plot_next = .false.
       endif
       if (s.ne.0) goto 999

C initialise view port
       call pgsetvp( graphic_view_port(1), graphic_view_port(2),
     *               graphic_view_port(3), graphic_view_port(4) )
       call pgsetwin( 0.0, 1.0, 0.0, 1.0 )

C check graphic status and if necessary re-initialise
       if (graphic_status.eq.0 .or. plot_refresh .or.
     *     (graphic_type.eq.graphic_scratch) ) then
         if (.not.graphic_transparent) then
            call pgsfs( 1 )
            call pgsci( colour_background )
            call pgrect( 0.0, 1.0, 0.0, 1.0 )
         endif
         graphic_status = 1
       endif
C take special action to setup scratch options
       if (graphic_type.eq.graphic_scratch .and.
     *     scratch_view_port_opt.eq.1 ) then
         xr = (graphic_view_port(2)-graphic_view_port(1))
         yr = (graphic_view_port(4)-graphic_view_port(3))
         x1 = graphic_view_port(1) + scratch_view_port(1)*xr
         x2 = graphic_view_port(1) + scratch_view_port(2)*xr
         y1 = graphic_view_port(3) + scratch_view_port(3)*yr
         y2 = graphic_view_port(3) + scratch_view_port(4)*yr
         call pgsetvp( x1,x2,y1,y2 )
         call pgwindow(0.0,1.0,0.0,1.0)
       endif
       call pgsci( colour_foreground )
       call graphic_set_line_opt( graphic_line_opts, s )
       call graphic_set_text_opt( graphic_text_opts, s )
       call graphic_copy_graphic( graphic, defn, s )
999    call cmd_err(s, 'Graphic_open',
     *                 'Failed to open graphics device')
       end

max_stars_repo_name: CavendishAstrophysics/anmap

max_issues_repo_name: CavendishAstrophysics/anmap

max_forks_repo_name: CavendishAstrophysics/anmap


text:
( oo testing )

need object  from lib/object.f
need testing from test/tester.f

verbose on
decimal

TESTING object
Object var o

{ o init -> }
{ o print cr -> }

TESTING simple class

object subclass point
    cell bytes y
    cell bytes x

    method get  2@ ;
    method put  2! ;

    m: print  x @ 0 .r '@' emit y ? ;m
end-class

{ point var p }
{ p get -> 0 0 }
{ 3 4 p put -> }
{ p get -> 3 4 }
{ p print cr -> }

TESTING class ivars

class rect
    point var p1
    point var p2
    m: get  p1 get  p2 get ;m
    m: put  p2 put  p1 put ;m
    m: print  p1 print  p2 print  ;m
    m: setupr ( pt -- )  get p1 put ;m
end-class

{ rect var r }
{ r get -> 0 0 0 0 }
{ 1 2 3 4 r put -> }
{ r get -> 1 2 3 4 }
{ r print cr -> }

TESTING subclass

rect subclass crect
    cell bytes color
    m: get super get color @ ;m
    m: print  super print  ." color " color ? ;m
    m: setcolor  color ! ;m
end-class

{ crect var rr }
{ rr get -> 0 0 0 0 0 }
{ 11 22 33 44 rr put -> }
{ 55 rr setcolor -> }
{ rr get -> 11 22 33 44 55 }
{ rr print cr -> }

TESTING access to super ivars

point subclass point2
    m: get x @ y @ ;m
end-class

{ point2 var p2 -> }
{ p2 get -> 0 0 }
{ 88 99 p2 put -> }
{ p2 get -> 88 99 }

TESTING self super

point subclass point3
    m: size  self get * ;m
end-class

{ point3 var p3 -> }
{ 3 4 p3 put -> }
{ p3 size -> 12 }

point subclass inverted-point
    m: put  swap super put  ;m
end-class

{ inverted-point var inv -> }
{ 3 4 inv put -> }
{ inv get -> 4 3 }

TESTING object initialization

point subclass fixed-point
    m: init  100 x !  200 y !  ;m
end-class

{ fixed-point var fixed -> }
{ fixed get -> 100 200 }

\ init with args
\ this is risky until we figure out
\ a good way to do this for ivars
\ but it const almost nothing so we can keep it

point subclass initialized-point
    m: init ( x y -- )  y !  x !  ;m
end-class

{ 111 222 initialized-point var ip -> }
{ ip get -> 111 222 }

max_stars_repo_name: amckewan/mcforth

max_issues_repo_name: amckewan/mcforth

max_forks_repo_name: amckewan/mcforth


text:
I graduated from Davis and no longer live nearby to try out all the restaurants.  Everything below is from my time in Davis, Sept 2003  August 2007.  Appreciate the DavisWiki; I wish more cities would have their own with an active community.

I love to promote diversity and native languages so please feel free to change the names of the restaurants here on my page!

Restaurants I have eaten at... (My rating out of 5)

  علي بابا Ali Baba  (4) Delicious gyros but fries are < Sams but Ill return
  Burger King  (3) No bad stories, just like any other fast food place
  Caffe Italia  (5) Great service, great food, good price, CRAYONS
  Cafe Casablanca  (3) WOW EXPENSIVE! The setting was completely cute with the movie going for people who wait to be seated. The service was excellent. The food was decent but definitely not worth the price. I ended up paying $20 for an entree, drink, tax and tip. If they bring down their prices, then Ill return.
  Cafe Roma  (4) Very good coffee, nice service, kinda shabby looking, will return again when theres music and its more busy
  Carls Jr.  (2) Pricy but on campus location is convenient
  Cenarios Pizza  (3) Decent pizza, Id eat it again
  Chuys Taqueria  (4) Now I dont have to drive hella far ) Love the tacos, the horchata was room temperature tho (
  Cindys  (2) Only thing good is the service and the malts
  Ciocolat  (3) Extremely delicious but very pricey!
  Coffee House  (3) Average, customer service could be better
  Cold Stone Creamery  (4) Friendly customer service and tasty ice cream.  Expensive tho
  Crepeville La ville des crêpes  (5) Tuna Melt Sandwich mmm Crepes mmm A tab bit pricy but the food is worth it
  Davis Noodle City  (4) Very friendly and best dumplings ever!
  Dos Coyotes  (1) Expensive and ewww
  El Mariachi  (5) mmm Burrito… and I love the salsa selection!
  富士のシェフ Fuji Chef (4) Good lunch buffet but wait was forever
  Fuzio  (3) Food was decent but not stellar.  Price is ok.
  Fluffy Donuts  (4) mmm Donut holes mmm
  Hibachi  (3) Very much like Teriyaki Express but you get less food.  But better seating
  Hoa Viet  (3) OK food, quick serve, cheap price
  The Hotdogger Hotdogger  (4) Delicious, quick service, skinny hot dog but tasty
  House of Chang  (5) Excellent Honey Walnut Prawns, good food, fast delivery
  Hunan  (0) I got the shits
  Huong Lan Sandwiches  (4) Delicious, tough bread, cute cashier D Definately will return
  IHOP Internationales Haus der Pfannkuchen  (2) Same generic food but always quick service and decent variety
  InNOut  (4) Grilled Cheese everytime, Root Beer Floats, Fries with no salt
  Jack in the Box  (3) Why did they change the pita? ( and the one downtown creeps me out
  Jade Garden  (4) Huge portions for the price, good food, will return
  Muta Fart Mnywo Jamba Juice  (3) Gift card + friend working there  cheap and worth it
  Kabul Afghan Cuisine  (4) The service was excellent; Ive never eaten Afghan food before so the server helped me.  The food was delicious and very happy with the choice.  Not a 5 because there is a belly dancer and I know that belly dancing is not Afghan; Ive heard they brought one in to attract more customers.
  KFC  (4) I love the sides… Chicken and Corn Tuesdays for $2.99
  La Esperanza  (4) The chips were fresh, quick service, food came out quickly and was good, horchata excellent
  Lamppost PIzza  (2) Overpriced and greasy.  Wont eat here again unless its free
  London Fishn Chips  (4) Excellent service, delicious calamari, will return
  Manna Korean Restaurant  (3) Had the BBQ Beef and didnt think anything special.  But I love the potstickers.  Ill return for those!
  Marble Slab Creamery  (3) Good tasting but not as good as Cold Stone, just a tad cheaper
  McDonalds  (1) 2 apple pies for $1 is the only thing Ill eat
  Mocha Joe  (5) The couple running the place is extremely kind, good coffee and its cheap!
  Mountain Mikes Pizza  (3) Average, Decent price with coupon
  Mr. Chans  (0) I got the shits
  New Delhi Chaat Cafe  (5) Excellent food, good service and good prices
  Nobu Hiro  (5) Excellent, quick service at the bar, get there at 11
  Norms Pizza  (4) DELICIOUS Philly Cheesecake, cooked when I ordered it.  Alas they closed (
  老茶馆 Old Teahouse  (4) Love the boba, shredded Chicken fried rice, cripsy chicken, no room to sit, wait is sometimes forever, check your change
  Osaka Sushi  (4) Pricy but you get quality and quantity for it; good service
  Papa Johns Padre Johns  (5) Delivery is awesome, gotta love the cheese sticks
  Papa Murphys  (5) Awesome pizza for a much cheaper price.  And cooking it at home is worth the wait and money I saved.
  Κοίλωμα Pita Pita Pit (3) Pricy but the late hours are wonderful
  Pizza Guys  (3) Good price, was stingy with the meat on my pizza and had to wait for the wings to cook (they said my order would be ready in 20 minutes and when I got there 30 minutes later, my wings were not even in the oven)
  Plutos  (5) Won me over several times.  Love those garlic fries
  Redrum Burger  (3) Expensive but good food
  Quiznos  (3) Too pricy but decent sandwiches
  Sams Mediterranean Cuisine  (4) Decent price for good food, loved the fries / (1) I went a second time and was sick for 3 days afterwards. ( I dont know what happened!
  上海镇 Shanghai Town  (4) Prices may seem expensive but you receive LOTS of food.  One ordered has turned into two meals.
  Sophias Thai Kitchen  (4) Cute little place, good food, too many spicy food though
  Starbucks  (2) Maybe Ive just had too much
  Steves Place Pizza  (5) Garlic Chicken and sun dried tomatoes.  A bit expensive but I think its worth it
  Caffè DellItaliano Delle Stringhe Strings Italian Cafe  (3) Soltanto degno esso durante i buffet di mercoledì (Translation: Only worth it during Wednesdays buffets)
  Sugar and Spice  (3) Very friendly, tastes good, limited selection, incredibly expensive.  Ill return when Im too lazy to cook my own Pilipino food.
  Symposium  (4) (?) Enjoyed the pizza and loved the crust.  Havent tried the restaurant yet.
  Taqueria Davis  (5) Hands down the best burritos in Davis.  Love the salsa and the horchata.  Very friendly.
  Taqueria Guadalajara  (4) Would have a perfect 5 if they had not messed up my order (
  明白な Teriyaki Teriyaki Express (5) 私は2 つの食事に teriyaki の1 つの版を回す。 veggies を愛しなさい (Translation: I turn one plate of teriyaki into two meals.  Love the veggies)
  2K Thai Food  (5) Inexpensive, clean, friendly, excellent food, wonderful service
  Thai Bistro  (4) Best customer service of all the Thai restaurants but not my fav
  Thai Recipes  (3) Decent food but was priced too high; get better tasting food for cheaper elsewhere
  Village Bakery  (4) Delicious surprise
  Wendys  (4) Pricy but open late
  Wok n Roll  (4) Cheap, good, tasty
  Woodstocks Pizza La pizza del Woodstock  (1) che cosa è così grande circa questo posto? (Translation: Whats so great about this place?)
  Zen Toro  (5) My highest rating.  You get quality and quantity for the price.  This is my favorite Japanese restaurant in town.  Only down side: there is no ice in the water.

Outside of Davis
  Chuys Taqueria in Winters  (4) Worth driving out there and loved the tacos
  California Pizza Kitchen in Sacramento  (5) Ive never ordered anything bad, everything is delicious!
  The Cheesecake Factory in Sacramento  (3) Everything on the menu is fried, need more variety
  Hooters in Sacramento  (4) Good Philly Cheesesteak.  Ok chicken wings, I ordered medium and they were not spicy at all.  Next time Im getting 3 Mile Island or 911
  Hot Dog on a Stick in Sacramento  (3) Good everything but way too expensive $7 for 1 hot dog on a stick, fries and a drink
  Manila Restaurant in Elk Grove  (3) 8 pages Chinese and 2 pages Filipino (as in the language); Need more Filipino and Pilipino food (Because they serve Americanize food (Filipino) and not the traditional Pilipino food), pricy for small quantity
  Tahoe Joe in Vacaville  (5) Excellent.  Delicious food for a good price and excellent service.  I love their wood steaks and root beer.
  BJs Restaurant and Brewery in Vacaville  (4) You get the quality for a good price.  I was just sad that they didnt have any root beer.  And the pizookie is scrumptous.
  Nations in Vacaville  (5) Nations has never let me down.  I grew up with Nations and I love coming here.  They cook your food when you order it, the portions are huge, and the pies are the best.
  Zacharys Pizza in Berkeley  (3) OK but definately not worth driving down to have some.  Sucks they dont take credit card.  But for the quality, the price is fine.  Does not compare at all to Chicago.

We both feel very strongly on this issue.  My edits to your page were over the top, intended to make a point, but they went way too far after the point was made.  My sincere apologies.  Users/JabberWokky

I like how you have some of the restaurant names listed in their native characters on this page along with the English words.  The restaurants page should be donethis way as well.  Unfortunately, I tried to use Chinese characters (中文), but the wiki headline macro wont display them correctly; it just shows the escape sequences (& #20013; & #25991;).   Users/CarlMcCabe CM this should work now.

I like the native language efforts, too.  Were too isolated in the U.S. Users/GrahamFreeman

Too bad no local restaurants serve Roman food... oh well, scratch another thing off the list of Things Latin Speakers Cant Translate. Users/CindySperry

According to their website, Jamba Juices name derives from the African word jama, meaning to celebrate. Thats nice of them to be multicultural and stuff, but last time I checked African wasnt a language. I did a bit of digging and they say elsewhere its swahili. Jama typed into a http://africanlanguages.com/kdp/index.php?len swahili dictionary translates to family or companions, so I cant corroborate their story. Interestingly, Jamba translates to fart. Im certain its syntacticly wrong, but above Ive haphazardly (mis)translated Jamba Juice to muta fart mnywo, where Jamba is fart, and juice is muta mnywo (sweet drink). Users/CraigBrozinsky

20060517 01:04:15 nbsp Hi JoAnna, I love this page! I have eaten at every restaurant in Davis, but never really had the energy to build a page about it.  Users/ChrisLambertus

20060701 18:42:21 nbsp They didnt have root beer or they were out of it?  BJs brew their own root beer  its delicious.  Maybe they were just out of the batch?  And I know its also on the desert menu as a float.  Users/EdWins ES
  They were out of the root beer ( Well I did end up going like an hour before they closed.  JR

20060829 00:57:13 nbsp what about Village Bakery? i recommend asking for pesto + tomato sauce :) Users/EmilyFrançais Frenchie

20060917 16:09:01 nbsp Im glad to see so many Horchata recommendations. My plan for the next few years: find the best horchata in Davis. Users/MoTorres

20061007 10:22:59 nbsp The problem is that he was messing around with his bio page, which isnt his. His personal page is his baby. His bio page (as a public figure) belongs to the community. Users/WilliamLewis

20070126 13:25:23 nbsp I love this page ) Oh and if you go the other way (opposite Vacaville) you get to Folsom, which also has a BJs Users/TusharRawat

20070129 02:23:49 nbsp you need to eat at the educated eatery once Users/StevenDaubert

20070222 10:42:03 nbsp i love this page.  It inspired me to create my own a while back.  I wish everyone would do something similar.  Its fun to see how people rank different restaurants.  I especially litke the native characters Users/MattHh

20070302 00:03:16 nbsp Hey Joanna come and visit my restaurant in Woodland.  We serve Japanese and Hawaiian Food.  Our address is 10 N East St.  Email me at rtaura@yahoo.com and I will send you a menu. Users/RobertTaura

20070302 09:44:04 nbsp Hey, JoAnna, youre very good at being sensitive to pigeonholing by race.  Im trying to avoid that in Ethnic and Cultural Organizations.  Do you have any thoughts on how not to lay it out so divisively but at the same time indexed for people looking for a particular group? Users/JabberWokky

20070302 10:08:29 nbsp JoAnna  see Ethnic and Cultural Organizations.  Theres a centralization going on, not deletion.  Your content was also moved to Demographics as well. Users/JabberWokky

20070302 11:35:26 nbsp Thanks for the comment JoAnna.  Certainly if a page exists, it shouldnt be deleted without some sort of discussion about its importance, as long as it is not blatant spam of course.  I was mainy trying to curb the continuous deleting and reviving of some pages that was going on.  Most of those thoughts could have been hashed out in a talk page before action was taken.  My comments werent directed at you specifically, just the situation in general.  Thanks. Users/DavidGrundler

20070302 12:06:31 nbsp I am going to be away for the weekend so I dont have much time to do edits, but if possible can u find some ASA and NAS people intersted in the wiki to add to the South Asian and Native American pages? Users/EricWu

20070302 12:33:24 nbsp I feel almost like the edit confirmation: Thank you for your attention to detail:)  Users/EricWu

20070302 12:46:44 nbsp JoAnna, you dont need to be so paranoid about people deleting the Mixed Race entry.  Its okay, were all in this together.  It actually hurts me that youd think anyone would be against you in this.  Were all working together to try and add more information.  Content was moved around, but nothing you ever wrote was ever deleted.  Its put me in an odd mood that youd think I (or anyone here on the wiki) would even consider silencing your voice.  This morning was about balancing and figuring out where to locate types of information, not silencing people or groups.  Fantastic entry, by the way.  You might want to even split out Mixed Race Issues at UC Davis in terms of scholorships and demographics... thats why I moved some of your earlier content to the Demographics entry, because it illustrates how poorly they cover some people. Id still like your feedback on how best to organize Ethnic and Cultural Organizations so they dont exclude or minimize multicultural groups and organizations while still having a structure allowing people to look up various groups.  Users/JabberWokky

20070302 14:47:51 nbsp Youre right... I started jumping around and moving stuff around without explaining first and giving you a chance to agree or disagree with the edits.  Please give Ethnic and Cultural Organizations/Talk a read to see what I was trying to do. Users/JabberWokky

20070420 09:22:12 nbsp the pilipino/filipino debate is opening up again on the restaurants page. do you remember where the original discussion of the issue came up, so we can link there and avoid future revert wars? Users/CraigBrozinsky

20070508 18:29:41 nbsp 20070508 11:28:39 nbsp Just ask them at la crepe to cook it on the third griddle or second griddle a bit longer and they will for sure. Users/StevenDaubert P.S. have you been by Icekrimski cafe ? Try the gelato and tell me how it stacks up to cold stone!

20070524 18:57:23 nbsp Awesome catch on Aggie Barbershop! http://cheshirehall.net/link/ws/smile.png  It is not like it is in an obscure corner of town, either. Users/JabberWokky

20070524 23:13:18 nbsp aggie barber shop alreayd exists, pretty sure Users/StevenDaubert

20070525 02:00:00 nbsp The aggie barber shop ? Users/StevenDaubert
PS The aggie barbershop  aggie barbershop {{{<}}} there is the difference, I dont go around deleting pages without a reason, perhaps you should look closer at recent changes edit comments, and your question would have answered itself D ...  P.P.S you still need to go to the educated eatery
   JoAnna is right  I thought it already existed too, so I did a search and it didnt come up.  I would have made the same duplication error.  Its because the search has been acting up for a couple weeks.  I know Philip has been working on fixing it, but it looks like there are still problems left. Users/JabberWokky
      I do not think this was a bug.  I searched for barber shop and found the result immediately.  Im guessing you searched for the single word barbershop.
       I searched for the aggie barber shop and found it instantly, I know this cause I had to link it to carriers carpet & floor care a couple days ago because he is one who cleans the store and I was the one setting up the wiki page for it, and this was of course  before the redirect, but the redirect is fine.  Users/StevenDaubert
         Ah, yes... not a bug in search.  A bug in the user.  I did do a search for Aggie Barbershop.  Regardless, it comes up under both now.  Not a biggie.  jw

20070704 13:26:34 nbsp Ive seen a few changes you made, like in fluffy donuts.  It seems that you rephrased things that were very well written but could possibly be misconstrued by sensitive people that are offended by raindrops and replaced it with colorless descriptive narration.  I think their is a vast canyon of difference between stylistic differences and the factually erroneous  with only one needing modification.  And please dont pass wikipedia guidelines as some sort of rebuke  because they are to writing as the DMV is to driving. Users/ChristopherMckenzie

20081019 09:00:07 nbsp you should give the putah creek cafe a shot next time your headed outside of Davis Westbound... Users/StevenDaubert

20081026 22:14:41 nbsp It probably would have been impossible to try every restaurant anyway, since the latest ones have seemed to to appeared and disappeared within a matter of months.  Users/ElleWeber


text:
module catch_error_module
  use errorfx, only : fatal_error, create_error, destroy_error, catch_error
  implicit none

contains

  ! A routine is called, which may throw an error (in this case it does). In case an error occured
  ! it will be caught/handled, so it won't do any harm when going out of scope.

  subroutine main()

    type(fatal_error), allocatable :: error

    ! Handling the error using error handling routine
    call routine1(error)
    call catch_error(error, handle_error)

    ! Handling the error with manual destruction. Leaving the scope during the error handling
    ! before the ``destroy(error)`` call would trigger an error stop!
    call routine1(error)
    if (allocated(error)) then
      print "(a,a,a,i0,a)", "Fatal error found: '", error%message, "' (code: ", error%code, ")"
      call destroy_error(error)
    end if

    ! Handling the error with separated deactivation and deallocation
    call routine1(error)
    if (allocated(error)) then
      call error%deactivate()
      print "(a,a,a,i0,a)", "Fatal error found: '", error%message, "' (code: ", error%code, ")"
      deallocate(error)
    end if

  contains

    subroutine handle_error(error)
      type(fatal_error), intent(in) :: error

      ! Note if needed, you have access to all variables in the routine above
      print "(a,a,a,i0,a)", "Fatal error found: '", error%message, "' (code: ", error%code, ")"

    end subroutine handle_error

  end subroutine main

  subroutine routine1(error)
    type(fatal_error), allocatable, intent(out) :: error

    ! Creating and throwing an error
    call create_error(error, message="Error created in routine1")
    return
    print "(a)", "you shoud not see this, as we returned due to an error already"

  end subroutine routine1

end module catch_error_module

program catch_error_program
  use catch_error_module, only : main
  implicit none

  call main()

end program catch_error_program

max_stars_repo_name: aradi/fx-error

max_issues_repo_name: aradi/errorfx

max_forks_repo_name: aradi/errorfx


text:
! { dg-do compile }
!
! PR fortran/36705
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>

save :: p
procedure() :: p
pointer :: p

contains

subroutine bar(x)
  procedure(), intent(in) :: x
  pointer :: x
end subroutine bar

end

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
! This file contains routines to make a visualization of a nbody simulation
! it is self contained and could be called from a running simulation.
! the data is passed through common blocks

!

module view_modifier

! This module provides facilities to modify the view in an OpenGL window.
! The mouse buttons and keyboard arrow keys can be used to zoom, pan,
! rotate and change the scale.  A menu or submenu can be used to select which
! buttons perform which function and to reset the view to the initial settings.
! This is limited to one window.

! William F. Mitchell
! william.mitchell@nist.gov
! Mathematical and Computational Sciences Division
! National Institute of Standards and Technology
! April, 1998

! To use this module:
!
! 1) put a USE view_modifier statement in any program unit that calls a
!    procedure in this module
!
! 2) set the initial operation assignments, view and scale below the
!    "Initial configuration" comment below
!
! 3) call view_modifier_init after glutCreateWindow
!    This is a function that returns integer(kind=glcint) menuid.  The menuid
!    is the ID returned by glutCreateMenu.  You can either use the view_modifier
!    menu as your menu by calling glutAttachMenu immediately after
!    view_modifier_init, as in
!       menuid = view_modifier_init()
!       call glutAttachMenu(GLUT_RIGHT_BUTTON)
!    or by using the menuid to attach a submenu to your own menu, as in
!       call glutAddSubMenu("View Modifier",menuid)
!
! 4) in any callback functions that update the display, put
!       call reset_view
!    as the first executable statement
!
! Note that view_modifier_init sets the callback functions for glutMouseFunc,
! glutMotionFunc and glutSpecialFunc, so don't call these yourself
!
! The menu allows you to select what operation is attached to the left and
! middle mouse buttons and arrow keys, reset to the initial view, and quit.
! The right mouse button should be used for the menu.

use opengl_gl
use opengl_glu
use opengl_glut
implicit none
private
public :: view_modifier_init, reset_view
private :: ZOOM, PAN, ROTATE, SCALEX, SCALEY, SCALEZ, RESET, QUIT, &
           PI, &
           left_button_func, middle_button_func, arrow_key_func, &
           init_lookat, init_lookfrom, &
           init_xscale_factor, init_yscale_factor, init_zscale_factor, &
           angle, shift, xscale_factor, yscale_factor, zscale_factor, &
           moving_left, moving_middle, begin_left, begin_middle, &
           cart2sphere, sphere2cart, cart3D_plus_cart3D, cart3D_minus_cart3D, &
           reset_to_init, mouse, motion, arrows, &
           menu_handler, set_left_button, set_middle_button, set_arrow_keys

integer(kind=glcint), parameter :: ZOOM = 1, PAN = 2, ROTATE = 3, SCALEX = 4, &
                      SCALEY = 5, SCALEZ = 6
integer(kind=glcint), parameter :: RESET = 10, QUIT = 11
real(kind=gldouble), parameter :: PI = 3.141592653589793_gldouble

type, private :: cart2D ! 2D cartesian coordinates
   real(kind=gldouble) :: x, y
end type cart2D

type, private :: cart3D ! 3D cartesian coordinates
   real(kind=gldouble) :: x, y, z
end type cart3D

type, private :: sphere3D ! 3D spherical coordinates
   real(kind=gldouble) :: theta, phi, rho
end type sphere3D

type(cart2D), save :: angle
type(cart3D), save :: shift
real(kind=gldouble), save :: xscale_factor, yscale_factor, zscale_factor
logical, save :: moving_left, moving_middle
type(cart2D), save :: begin_left, begin_middle

interface operator(+)
   module procedure cart3D_plus_cart3D
end interface
interface operator(-)
   module procedure cart3D_minus_cart3D
end interface

! ------- Initial configuration -------

! Set the initial operation performed by each button and the arrow keys.
! The operations are ZOOM, PAN, ROTATE, SCALEX, SCALEY, and SCALEZ

integer, save ::   left_button_func = ROTATE, &
                 middle_button_func = ZOOM, &
                     arrow_key_func = PAN

! Set the initial view as the point you are looking at, the point you are
! looking from, and the scale factors

type(cart3D), parameter :: &
     init_lookat = cart3D(0.0_gldouble, 0.0_gldouble, 0.0_gldouble), &
   init_lookfrom = cart3D(6.0_gldouble, -12.0_gldouble, 3.0_gldouble)

real(kind=gldouble), save:: &
   init_xscale_factor = 1.0_gldouble, &
   init_yscale_factor = 1.0_gldouble, &
   init_zscale_factor = 1.0_gldouble

! -------- end of Initial configuration ------

contains

!          -------------
subroutine reset_to_init
!          -------------

! This resets the view to the initial configuration

type(sphere3D) :: slookfrom

slookfrom = cart2sphere(init_lookfrom-init_lookat)
angle%x = -180.0_gldouble*slookfrom%theta/PI - 90.0_gldouble
angle%y = -180.0_gldouble*slookfrom%phi/PI
shift%x = 0.0_gldouble
shift%y = 0.0_gldouble
shift%z = -slookfrom%rho
xscale_factor = init_xscale_factor
yscale_factor = init_yscale_factor
zscale_factor = init_zscale_factor

 call glutPostRedisplay

return
end subroutine reset_to_init

!          ----------
subroutine reset_view
!          ----------

! This routine resets the view to the current orientation and scale

 call glMatrixMode(GL_MODELVIEW)
 call glPopMatrix
 call glPushMatrix
 call glTranslated(shift%x, shift%y, shift%z)
 call glRotated(angle%x, 0.0_gldouble, 0.0_gldouble, 1.0_gldouble)
 call glRotated(angle%y, cos(PI*angle%x/180.0_gldouble), &
               -sin(PI*angle%x/180.0_gldouble), 0.0_gldouble)
 call glTranslated(-init_lookat%x, -init_lookat%y, -init_lookat%z)
 call glScaled(xscale_factor,yscale_factor,zscale_factor)

return
end subroutine reset_view

!          -----
subroutine mouse(button, state, x, y)
!          -----
integer(kind=glcint), intent(in out) :: button, state, x, y

! This gets called when a mouse button changes

  if (button == GLUT_LEFT_BUTTON .and. state == GLUT_DOWN) then
    moving_left = .true.
    begin_left = cart2D(x,y)
  endif
  if (button == GLUT_LEFT_BUTTON .and. state == GLUT_UP) then
    moving_left = .false.
  endif
  if (button == GLUT_MIDDLE_BUTTON .and. state == GLUT_DOWN) then
    moving_middle = .true.
    begin_middle = cart2D(x,y)
  endif
  if (button == GLUT_MIDDLE_BUTTON .and. state == GLUT_UP) then
    moving_middle = .false.
  endif
end subroutine mouse

!          ------
subroutine motion(x, y)
!          ------
integer(kind=glcint), intent(in out) :: x, y

! This gets called when the mouse moves

integer :: button_function
type(cart2D) :: begin
real(kind=gldouble) :: factor

! Determine and apply the button function

if (moving_left) then
   button_function = left_button_func
   begin = begin_left
else if(moving_middle) then
   button_function = middle_button_func
   begin = begin_middle
end if

select case(button_function)
case (ZOOM)
   if (y < begin%y) then
      factor = 1.0_gldouble/(1.0_gldouble + .002_gldouble*(begin%y-y))
   else if (y > begin%y) then
      factor = 1.0_gldouble + .002_gldouble*(y-begin%y)
   else
      factor = 1.0_gldouble
   end if
   shift%z = factor*shift%z
case (PAN)
   shift%x = shift%x + .01*(x - begin%x)
   shift%y = shift%y - .01*(y - begin%y)
case (ROTATE)
   angle%x = angle%x + (x - begin%x)
   angle%y = angle%y + (y - begin%y)
case (SCALEX)
   if (y < begin%y) then
      factor = 1.0_gldouble + .002_gldouble*(begin%y-y)
   else if (y > begin%y) then
      factor = 1.0_gldouble/(1.0_gldouble + .002_gldouble*(y-begin%y))
   else
      factor = 1.0_gldouble
   end if
   xscale_factor = xscale_factor * factor
case (SCALEY)
   if (y < begin%y) then
      factor = 1.0_gldouble + .002_gldouble*(begin%y-y)
   else if (y > begin%y) then
      factor = 1.0_gldouble/(1.0_gldouble + .002_gldouble*(y-begin%y))
   else
      factor = 1.0_gldouble
   end if
   yscale_factor = yscale_factor * factor
case (SCALEZ)
   if (y < begin%y) then
      factor = 1.0_gldouble + .002_gldouble*(begin%y-y)
   else if (y > begin%y) then
      factor = 1.0_gldouble/(1.0_gldouble + .002_gldouble*(y-begin%y))
   else
      factor = 1.0_gldouble
   end if
   zscale_factor = zscale_factor * factor
end select

! update private variables and redisplay

if (moving_left) then
   begin_left = cart2D(x,y)
else if(moving_middle) then
   begin_middle = cart2D(x,y)
endif

if (moving_left .or. moving_middle) then
   call glutPostRedisplay
endif

return
end subroutine motion

!          ------
subroutine arrows(key, x, y)
!          ------
integer(glcint), intent(in out) :: key, x, y

! This routine handles the arrow key operations

real(kind=gldouble) :: factor

select case(arrow_key_func)
case(ZOOM)
   select case(key)
   case(GLUT_KEY_DOWN)
      factor = 1.0_gldouble + .02_gldouble
   case(GLUT_KEY_UP)
      factor = 1.0_gldouble/(1.0_gldouble + .02_gldouble)
   case default
      factor = 1.0_gldouble
   end select
   shift%z = factor*shift%z
case(PAN)
   select case(key)
   case(GLUT_KEY_LEFT)
      shift%x = shift%x - .02
   case(GLUT_KEY_RIGHT)
      shift%x = shift%x + .02
   case(GLUT_KEY_DOWN)
      shift%y = shift%y - .02
   case(GLUT_KEY_UP)
      shift%y = shift%y + .02
   end select
case(ROTATE)
   select case(key)
   case(GLUT_KEY_LEFT)
      angle%x = angle%x - 1.0_gldouble
   case(GLUT_KEY_RIGHT)
      angle%x = angle%x + 1.0_gldouble
   case(GLUT_KEY_DOWN)
      angle%y = angle%y + 1.0_gldouble
   case(GLUT_KEY_UP)
      angle%y = angle%y - 1.0_gldouble
   end select
case(SCALEX)
   select case(key)
   case(GLUT_KEY_DOWN)
      factor = 1.0_gldouble/(1.0_gldouble + .02_gldouble)
   case(GLUT_KEY_UP)
      factor = 1.0_gldouble + .02_gldouble
   case default
      factor = 1.0_gldouble
   end select
   xscale_factor = xscale_factor * factor
case(SCALEY)
   select case(key)
   case(GLUT_KEY_DOWN)
      factor = 1.0_gldouble/(1.0_gldouble + .02_gldouble)
   case(GLUT_KEY_UP)
      factor = 1.0_gldouble + .02_gldouble
   case default
      factor = 1.0_gldouble
   end select
   yscale_factor = yscale_factor * factor
case(SCALEZ)
   select case(key)
   case(GLUT_KEY_DOWN)
      factor = 1.0_gldouble/(1.0_gldouble + .02_gldouble)
   case(GLUT_KEY_UP)
      factor = 1.0_gldouble + .02_gldouble
   case default
      factor = 1.0_gldouble
   end select
   zscale_factor = zscale_factor * factor

end select

call glutPostRedisplay

return
end subroutine arrows

!          ------------
subroutine menu_handler(value)
!          ------------
integer(kind=glcint), intent(in out) :: value

! This routine handles the first level entries in the menu

select case(value)

case(RESET)
   call reset_to_init
case(QUIT)
   call glutLeaveMainLoop()

end select

return
end subroutine menu_handler

!          ---------------
subroutine set_left_button(value)
!          ---------------
integer(kind=glcint), intent(in out) :: value

! This routine sets the function of the left button as given by menu selection

left_button_func = value

return
end subroutine set_left_button

!          -----------------
subroutine set_middle_button(value)
!          -----------------
integer(kind=glcint), intent(in out) :: value

! This routine sets the function of the middle button as given by menu selection

middle_button_func = value

return
end subroutine set_middle_button

!          --------------
subroutine set_arrow_keys(value)
!          --------------
integer(kind=glcint), intent(in out) :: value

! This routine sets the function of the arrow keys as given by menu selection

arrow_key_func = value

return
end subroutine set_arrow_keys

!        ------------------
function view_modifier_init(scale) result(menuid)
!        ------------------

real(kind=gldouble), optional,intent(in) :: scale

integer(kind=glcint) :: menuid

! This initializes the view modifier variables and sets initial view.
! It should be called immediately after glutCreateWindow

integer(kind=glcint) :: button_left, button_middle, arrow_keys

if(present(scale)) then
init_xscale_factor=scale
init_yscale_factor=scale
init_zscale_factor=scale
endif

! set the callback functions

call glutMouseFunc(mouse)
call glutMotionFunc(motion)
call glutSpecialFunc(arrows)

! create the menu

button_left = glutCreateMenu(set_left_button)
call glutAddMenuEntry("rotate",ROTATE)
call glutAddMenuEntry("zoom",ZOOM)
call glutAddMenuEntry("pan",PAN)
call glutAddMenuEntry("scale x",SCALEX)
call glutAddMenuEntry("scale y",SCALEY)
call glutAddMenuEntry("scale z", SCALEZ)
button_middle = glutCreateMenu(set_middle_button)
call glutAddMenuEntry("rotate",ROTATE)
call glutAddMenuEntry("zoom",ZOOM)
call glutAddMenuEntry("pan",PAN)
call glutAddMenuEntry("scale x",SCALEX)
call glutAddMenuEntry("scale y",SCALEY)
call glutAddMenuEntry("scale z", SCALEZ)
arrow_keys = glutCreateMenu(set_arrow_keys)
 call glutAddMenuEntry("rotate",ROTATE)
 call glutAddMenuEntry("zoom",ZOOM)
 call glutAddMenuEntry("pan",PAN)
 call glutAddMenuEntry("scale x",SCALEX)
 call glutAddMenuEntry("scale y",SCALEY)
 call glutAddMenuEntry("scale z", SCALEZ)
 menuid = glutCreateMenu(menu_handler)
 call glutAddSubMenu("left mouse button",button_left)
 call glutAddSubMenu("middle mouse button",button_middle)
 call glutAddSubMenu("arrow keys",arrow_keys)
 call glutAddMenuEntry("reset to initial view",RESET)
 call glutAddMenuEntry("quit",QUIT)

! set the perspective

 call glMatrixMode(GL_PROJECTION)
 call gluPerspective(30.0_gldouble, 1.0_gldouble, 0.01_gldouble, 200.0_gldouble)

! set the initial view

 call glPushMatrix
 call reset_to_init

return
end function view_modifier_init

!        -----------
function sphere2cart(spoint) result(cpoint)
!        -----------
type(sphere3D), intent(in) :: spoint
type(cart3D) :: cpoint

! This converts a 3D point from spherical to cartesean coordinates

real(kind=gldouble) :: t,p,r

t=spoint%theta
p=spoint%phi
r=spoint%rho

cpoint%x = r*cos(t)*sin(p)
cpoint%y = r*sin(t)*sin(p)
cpoint%z = r*cos(p)

return
end function sphere2cart

!        -----------
function cart2sphere(cpoint) result(spoint)
!        -----------
type(cart3D), intent(in) :: cpoint
type(sphere3D) :: spoint

! This converts a 3D point from cartesean to spherical coordinates

real(kind=gldouble) :: x,y,z

x=cpoint%x
y=cpoint%y
z=cpoint%z

spoint%rho = sqrt(x*x+y*y+z*z)
if (x==0.0_gldouble .and. y==0.0_gldouble) then
   spoint%theta = 0.0_gldouble
else
   spoint%theta = atan2(y,x)
end if
if (spoint%rho == 0.0_gldouble) then
   spoint%phi = 0.0_gldouble
else
   spoint%phi = acos(z/spoint%rho)
endif

return
end function cart2sphere

!        ------------------
function cart3D_plus_cart3D(cart1,cart2) result(cart3)
!        ------------------
type(cart3D), intent(in) :: cart1, cart2
type(cart3D) :: cart3

! Compute the sum of two 3D cartesean points

cart3%x = cart1%x + cart2%x
cart3%y = cart1%y + cart2%y
cart3%z = cart1%z + cart2%z

return
end function cart3D_plus_cart3D

!        -------------------
function cart3D_minus_cart3D(cart1,cart2) result(cart3)
!        -------------------
type(cart3D), intent(in) :: cart1, cart2
type(cart3D) :: cart3

! Compute the difference of two 3D cartesean points

 cart3%x = cart1%x - cart2%x
 cart3%y = cart1%y - cart2%y
 cart3%z = cart1%z - cart2%z

return
end function cart3D_minus_cart3D

end module view_modifier

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

module nbody_viewer
use opengl_gl
use opengl_glu
use opengl_glut
use view_modifier

implicit none

integer, parameter :: NMAX=2000000

real(kind=gldouble), parameter :: M_PI = 3.14159265358979323846_gldouble

type star
	real(kind=glfloat) x(0:1),y(0:1),z(0:1)
!	real(glfloat),dimension(3) :: &
!	color=(/1.0_glfloat,1.0_glfloat,1.0_glfloat,1.0_glfloat/)
end type star

integer(GLenum) doubleBuffer

logical,save :: show_gas=.TRUE., show_stars=.TRUE., show_halo=.TRUE., &
	 update_flag=.TRUE.,show_age=.FALSE.,show_temp=.FALSE.,     &
	 show_fuvheat=.FALSE.,show_div=.FALSE.,show_hsm=.FALSE.

integer, save :: gas_color,star_color,halo_color

integer(glint), save ::framerate=100;

integer(glint), parameter:: FASTUPDATE=100,SLOWUPDATE=5000

real(kind=glfloat),save :: pointsize_gas=3,pointsize_stars=1.5,pointsize_halo=10.

real(kind=glfloat), dimension(3) :: pointpar=(/0.15,0.075,0.026/)

real(kind=gldouble), save :: initialbox
real(kind=gldouble) :: wwidth, wheight

 contains

recursive subroutine starreset(dummy)
	include 'globals.h'
	integer(glint),intent(inout) :: dummy
        real(kind=glfloat) :: xt,yt,zt,temp,red,green,blue,alpha_c
	integer :: i,step
	real(kind=glfloat) :: starscale=10.   ! scaling of brightness of stars with age
	real(kind=glfloat) :: lhmin,lhmax

 step=max(nbodies/NMAX,1)
 call gldeletelists(1,3)

 lhmin=log(minval(hsmooth(1:nsph)))
 lhmax=log(maxval(hsmooth(1:nsph)))

if(show_gas) then

	call glNewList(1,GL_COMPILE)
	call glPointSize( pointsize_gas)
	if(show_fuvheat.OR.show_temp) then
	call glColor4f(.9_glfloat, .6_glfloat, .6_glfloat,.6_glfloat)
	else
	call glColor4f(1._glfloat, .8_glfloat, .8_glfloat,.6_glfloat)
	endif
	call glBegin(GL_POINTS)
	do i=1,nsph,step

	xt=pos(i,1)
	yt=pos(i,2)
	zt=pos(i,3)

	if(show_temp) then

	  temp=(alog10(csound(i)/.015))/2.
	  red=.4+.8*temp
	  blue=1.-2*temp*(1-temp)
	  green=.2+.6*temp**2
          alpha_c=.6
!	  alpha_c=.2+.5*temp
	  call glColor4f(red, green, blue,alpha_c)

	end if

	if(show_fuvheat) then

	  if(fuvheat(i).ge.0) then
	  temp=log(fuvheat(i))-log(7.)
	  red=.2+temp/3
	  blue=1.+temp/3
	  green=.2+temp/3
	  alpha_c=.6
	  call glColor4f(red, green, blue,alpha_c)
	  endif
	end if

	if(show_div) then

	  red=0.
	  blue=0.
	  green=0.
	  if(hsmdivv(i).GT.0) then
          red=1.
          else
          blue=1.
          endif
          alpha_c=.6
	  call glColor4f(red, green, blue,alpha_c)

	end if

	if(show_hsm) then

	  green=(log(hsmooth(i))-lhmin)/(lhmax-lhmin)
	  blue=0.
	  red=1-green
    alpha_c=.7-.7*green
	  call glColor4f(red, green, blue,alpha_c)

	end if

	call glVertex3f(xt,yt,zt)

	end do
        call glEnd()
	call glEndList()

end if

if(show_stars) then

	call glNewList(2,GL_COMPILE)
	call glPointSize( pointsize_stars)
	call glColor4f(.8_glfloat, .8_glfloat, .6_glfloat,.6_glfloat)
	call glBegin(GL_POINTS)
	do i=nbodies-nstar+1,nbodies,step

	xt=pos(i,1)
	yt=pos(i,2)
	zt=pos(i,3)

	if(show_age) then

	 temp=exp((tform(i)-tnow)/starscale)

	red=.7+.3*temp;green=.6+.4*temp;blue=.3+.7*temp

	call glColor4f(red, green, blue,.6_glfloat)
!	call glPointSize( (1._glfloat+3._glfloat*temp))
	end if

	call glVertex3f(xt,yt,zt)
	end do
        call glEnd()
	call glEndList()

end if

! halo
if(show_halo) then

	call glNewList(3,GL_COMPILE)
	call glPointSize( pointsize_halo)
	call glColor4f(.25_glfloat, .25_glfloat, 1._glfloat,.9_glfloat)
	call glBegin(GL_POINTS)
	do i=nsph+1,nbodies-nstar,step

	xt=pos(i,1)
	yt=pos(i,2)
	zt=pos(i,3)

!	red=.75;blue=.75;green=.75
!	call glColor4f(red, green, blue,.8_glfloat)

	call glVertex3f(xt,yt,zt)

	end do
        call glEnd()
	call glEndList()

end if

 call glutPostRedisplay

 if(update_flag) call glutTimerFunc( framerate, starreset, 0)

end subroutine starreset

function starscale() result(scale_factor)

	include 'globals.h'
	real(kind=gldouble) :: maxcor,maxcorg,maxcors,scale_factor
! schaal:
	maxcor=maxval(abs(pos(1:nbodies,1:3)))
	if(maxcor.le.0) maxcor=1.
        if(nsph.gt.0) then
	maxcorg=maxval(abs(pos(1:nsph,1:3)))
	endif
	if(maxcorg.le.0) maxcorg=maxcor
        if(nstar.gt.0) then
	maxcors=maxval(abs(pos(nbodies-nstar+1:nbodies,1:3)))
	endif
	if(maxcors.le.0) maxcors=maxcor
	maxcor=(maxcor*maxcorg*maxcors)**.33333
	scale_factor=2._gldouble/maxcor
	initialbox=2*maxcor
	return
end function starscale

subroutine outputtext(x,y,s)
  real(kind=gldouble) :: x,y
  character :: s*(*)
  character :: c
  integer :: i,lenc

  call glrasterpos2d(x,y)
  lenc = len(s)
  do i=1,lenc
    c = s(i:i)
    call glutbitmapcharacter(GLUT_BITMAP_HELVETICA_18, &
          ichar(c))
  end do
end subroutine outputtext

subroutine text
 include 'globals.h'
  character*8 rs
  call glmatrixmode(GL_PROJECTION)
  call glPushMatrix
  call glLoadIdentity
  call glortho(0._gldouble, wwidth, 0._gldouble, wheight,-1._gldouble,1._gldouble)
  call glmatrixmode(GL_MODELVIEW)
  call glPushMatrix
  call glLoadIdentity
  call glColor4f(0.0_glfloat,.5_glfloat,1.0_glfloat,0.5_glfloat)
  if(wheight.gt.120) then
  if(wwidth.gt.310) then
  write(rs,'(f8.2)') tnow*timescale/year/1.e6
  call outputtext(3._gldouble,3._gldouble,'time (Myr):'//rs)
  write(rs,'(f8.2)') initialbox*unitl_in_kpc
  call outputtext(wwidth-156._gldouble,3._gldouble,'box (kpc):'//rs)
  endif

  if(wwidth.gt.200) then
!  write(rs,'(I10)') nbodies-nstar-nsph
  call itos(nbodies-nsph-nstar,8,rs)
  call outputtext(3._gldouble,wheight-20._gldouble,'halo:')
  call outputtext(70._gldouble,wheight-20._gldouble,trim(rs))
  call itos(nsph,8,rs)
  call outputtext(3._gldouble,wheight-40._gldouble,'gas:')
  call outputtext(70._gldouble,wheight-40._gldouble,rs)
  call itos(nstar,8,rs)
  call outputtext(3._gldouble,wheight-60._gldouble,'stars:')
  call outputtext(70._gldouble,wheight-60._gldouble,rs)
  endif
  endif
  call glPopMatrix
  call glmatrixmode(GL_PROJECTION)
  call glPopMatrix
  call glmatrixmode(GL_MODELVIEW)
end subroutine text

subroutine reshape( w,h)
 integer(glint), intent(inout) :: w,h
 real(gldouble) ratio
 wwidth=w
 if(h.GT.1) ratio=w/(1.*h)
 wheight=MAX(h,1)
 call glViewPort(0,0,w,h)
 call glMatrixMode(GL_PROJECTION)
 call glLoadIdentity
 call gluPerspective(30.0_gldouble, ratio, 0.01_gldouble, 200.0_gldouble)

end subroutine reshape

subroutine display

 call reset_view
 call glClearColor(0.02_glfloat,0.02_glfloat,0.02_glfloat, 0.0_glfloat)
 call glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))

 call glBlendFunc(GL_SRC_ALPHA, GL_ONE)
 call glDepthFunc(GL_ALWAYS)
 call glCallList(2)
 call glCallList(1)
 call glCallList(3)
 call glBlendFunc(GL_SRC_ALPHA, GL_ZERO)
 call glDepthFunc(GL_LESS)
 call glColor4f(.3_glfloat, .3_glfloat, .9_glfloat,.9_glfloat)
 call glutWireCube(initialbox)
 call glBlendFunc(GL_ONE, GL_ONE_MINUS_SRC_ALPHA)
! call glDisable(GL_BLEND)
 call glDisable(GL_DEPTH_TEST)
 call text
! call glEnable(GL_BLEND)
 call glEnable(GL_DEPTH_TEST)
 call glutSwapBuffers

end subroutine display

subroutine axes

 call glNewList(3,GL_COMPILE)

! Draw axes so we know the orientation

 call glBegin(GL_LINES)
 call glVertex3f(0.0_glfloat,0.0_glfloat,0.0_glfloat)
 call glVertex3f(2.0_glfloat,0.0_glfloat,0.0_glfloat)
 call glVertex3f(0.0_glfloat,0.0_glfloat,0.0_glfloat)
 call glVertex3f(0.0_glfloat,2.0_glfloat,0.0_glfloat)
 call glVertex3f(0.0_glfloat,0.0_glfloat,0.0_glfloat)
 call glVertex3f(0.0_glfloat,0.0_glfloat,2.0_glfloat)

! Draw crude x, y and z to label the axes

 call glVertex3f(2.1_glfloat,-0.1_glfloat,0.1_glfloat) ! X
 call glVertex3f(2.1_glfloat,0.1_glfloat,-0.1_glfloat)
 call glVertex3f(2.1_glfloat,-0.1_glfloat,-0.1_glfloat)
 call glVertex3f(2.1_glfloat,0.1_glfloat,0.1_glfloat)
 call glVertex3f(0.1_glfloat,2.1_glfloat,0.1_glfloat) ! Y
 call glVertex3f(0.0_glfloat,2.1_glfloat,0.0_glfloat)
 call glVertex3f(-0.1_glfloat,2.1_glfloat,0.1_glfloat)
 call glVertex3f(0.1_glfloat,2.1_glfloat,-0.1_glfloat)
 call glVertex3f(-0.1_glfloat,0.1_glfloat,2.1_glfloat) ! Z
 call glVertex3f(0.1_glfloat,0.1_glfloat,2.1_glfloat)
 call glVertex3f(0.1_glfloat,0.1_glfloat,2.1_glfloat)
 call glVertex3f(-0.1_glfloat,-0.1_glfloat,2.1_glfloat)
 call glVertex3f(-0.1_glfloat,-0.1_glfloat,2.1_glfloat)
 call glVertex3f(0.1_glfloat,-0.1_glfloat,2.1_glfloat)
 call glEnd

 call glEndList

end subroutine axes

subroutine visible(state)
integer(glcint),intent(inout) :: state
  if (state == GLUT_VISIBLE) then
!   if(.not.update_flag) call glutTimerFunc( framerate, starreset,0)
   else
   update_flag=.FALSE.
  endif
end subroutine visible

subroutine update_menu(optie)
integer(glcint),intent(inout) ::optie
logical ::flag
integer(glint) :: dummy

select case(optie)

case(1)
flag=update_flag
update_flag=.FALSE.
if(.NOT.update_flag) call starreset(dummy)
update_flag=flag
case(2)
framerate=SLOWUPDATE
if(.not.update_flag) then
  update_flag=.TRUE.
  call starreset(dummy)
end if
case(3)
framerate=FASTUPDATE
if(.not.update_flag) then
  update_flag=.TRUE.
  call starreset(dummy)
end if
case(4)
update_flag=.FALSE.
case default

end select

end subroutine update_menu

subroutine show_menu(optie)
integer(glcint),intent(inout) :: optie
logical :: flag
integer(glint) :: dummy

select case (optie)
case(1)
show_stars=.NOT.show_stars
case(2)
show_gas=.NOT.show_gas
case(3)
show_halo=.NOT.show_halo
case(4)
 if(pointsize_gas.LT.10) then
 pointsize_gas=pointsize_gas*1.5
 pointsize_stars=pointsize_stars*1.5
 pointsize_halo=pointsize_halo*1.5
 endif
case(5)
 if(pointsize_gas.GT.1) then
 pointsize_gas=pointsize_gas/1.5
 pointsize_stars=pointsize_stars/1.5
 pointsize_halo=pointsize_halo/1.5
 endif
case default

end select

flag=update_flag
update_flag=.FALSE.
call starreset(dummy)
update_flag=flag

end subroutine show_menu

subroutine prop_menu(optie)
integer(glcint), intent(inout)::optie
logical :: flag
integer(glint) :: dummy

select case (optie)
case(1)
show_temp=.FALSE.
show_age=.FALSE.
show_fuvheat=.FALSE.
show_div=.FALSE.
show_hsm=.FALSE.
case(2)
show_temp=.NOT.show_temp
case(3)
show_age=.NOT.show_age
case(4)
show_fuvheat=.NOT.show_fuvheat
case(5)
show_div=.NOT.show_div
case(6)
show_hsm=.NOT.show_hsm
case default

end select

flag=update_flag
update_flag=.FALSE.
call starreset(dummy)
update_flag=flag

end subroutine prop_menu

end module nbody_viewer

subroutine viewbodies
 use nbody_viewer
 use view_modifier
 use opengl_gl
 use opengl_glut
 use opengl_glu

implicit none

integer(glcint) :: i,j,k,l
integer(glcint) :: win,menu

 if(glutGet(GLUT_ELAPSED_TIME).NE.0) then
!  print*,'already viewer present?'
!  return
 endif
 call glutInit
 call glutInitDisplayMode(ior(GLUT_DOUBLE,ior(GLUT_RGBA,GLUT_DEPTH)))
 call glutInitWindowPosition(100,100)
 call glutInitWindowSize(600,350)

win=glutCreateWindow("Stars3D Viewer")

i=glutCreateMenu(update_menu)
 call glutaddmenuentry('refresh view', 1)
 call glutaddmenuentry('slow update', 2)
 call glutaddmenuentry('fast update', 3)
 call glutaddmenuentry('no update', 4)

j=glutCreateMenu(show_menu)
 call glutaddmenuentry('toggle stars', 1)
 call glutaddmenuentry('toggle gas', 2)
 call glutaddmenuentry('toggle halo', 3)
 call glutaddmenuentry('increase pointsize', 4)
 call glutaddmenuentry('decrease pointsize', 5)

k=glutCreateMenu(prop_menu)
 call glutaddmenuentry('plain',1)
 call glutaddmenuentry('toggle temperature', 2)
 call glutaddmenuentry('toggle age', 3)
 call glutaddmenuentry('toggle fuvheat', 4)
 call glutaddmenuentry('toggle divv', 5)
 call glutaddmenuentry('toggle hsm', 6)

menu= view_modifier_init(starscale())

 call glutAttachMenu(GLUT_RIGHT_BUTTON)

 call glutaddsubmenu('update options', i)
 call glutaddsubmenu('view options', j)
 call glutaddsubmenu('show properties',k)

 call glutDisplayFunc(display)
 call glutReshapeFunc(reshape)

 call glClearColor(0.0_glclampf, 0.0_glclampf, 0.0_glclampf, 1.0_glclampf)

 call glEnable(GL_DEPTH_TEST)
 call glEnable(GL_BLEND)
 call glBlendFunc(GL_SRC_ALPHA, GL_ONE)
 call glEnable(GL_LINE_SMOOTH)
 call glEnable(GL_POINT_SMOOTH)
 call glHint(GL_LINE_SMOOTH_HINT, GL_NICEST)
 call glHint(GL_POINT_SMOOTH_HINT, GL_FASTEST)
! CALL glPointParameterfvEXT(GL_DISTANCE_ATTENUATION_EXT,pointpar)
! call glPointParameterfEXT(GL_POINT_SIZE_MIN_EXT, 1._glfloat)
! call glPointParameterfEXT(GL_POINT_FADE_THRESHOLD_SIZE_EX, 0._glfloat)

 call glutTimerFunc(100, starreset,0)
 call glutVisibilityFunc(visible)

 call glutSetOption(GLUT_ACTION_ON_WINDOW_CLOSE,GLUT_ACTION_GLUTMAINLOOP_RETURNS)
 call glutMainLoop()

end subroutine viewbodies

subroutine pt_setup

end subroutine pt_setup

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse