SUBROUTINE beamdis(loads,nf,ratmax,interp,nels,ell,argv,nlen,ips)
!
! This subroutine produces a PostScript output file "*.dis" displaying
! the deformed 1-D finite element mesh.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::loads(0:),ratmax,ell(:)
 INTEGER,INTENT(IN)::ips,nf(:,:),nels,interp,nlen
 REAL(iwp)::width,height,scale=72,sxy,xo,yo,x,y,dismag,vmax
 REAL(iwp)::xmin,xmax,ymin,ymax,xnow,dmax,zero=0.0_iwp,pt5=0.5_iwp,       &
   opt5=1.5_iwp,fpt5=5.5_iwp,d8=8.0_iwp,ept5=8.5_iwp,d11=11.0_iwp,        &
   one=1.0_iwp,two=2.0_iwp,thr=3.0_iwp,                                   &
   localx,globalx,na,nb,nc,nd,ll,wold,wnew
 INTEGER::i,j,nn
 CHARACTER(LEN=15)::argv
 REAL(iwp),ALLOCATABLE::xcoord(:)
 OPEN(ips,FILE=argv(1:nlen)//'.dis')
!
 nn=nels+1
 ALLOCATE(xcoord(nn))

 xmin=zero
 xmax=zero
 xnow=zero
 ymin=zero
 ymax=zero

 xcoord(1)=xnow

 DO i=2,nn
   xnow=xnow+ell(i-1)
   xcoord(i)=xnow
 END DO

 xmax=xcoord(nn)

 DO i=1,nn
    IF(loads(nf(1,i))<ymin)ymin=loads(nf(1,i))
    IF(loads(nf(1,i))>ymax)ymax=loads(nf(1,i))
 END DO

 width=xmax-xmin
 height=ymax-ymin
 dmax=ratmax*width
 IF(height>width)dmax=ratmax*height
!
 vmax=zero
 DO i=1,nn
     IF(ABS(loads(nf(1,i)))>vmax)vmax=ABS(loads(nf(1,i)))
 END DO
 dismag=dmax/vmax
!
 ymin=zero
 ymax=zero

 DO i=1,nn
   IF(dismag*loads(nf(1,i))<ymin)                            &
     ymin=dismag*loads(nf(1,i))
   IF(dismag*loads(nf(1,i))>ymax)                            &
     ymax=dismag*loads(nf(1,i))
!
   IF(loads(nf(1,i))<ymin)ymin=loads(nf(1,i))
   IF(loads(nf(1,i))>ymax)ymax=loads(nf(1,i))
 END DO
!
 width =xmax-xmin
 height=ymax-ymin
!
!                       allow 1.5" margin minimum on each side of figure
!
!                       portrait mode
!
 IF(height.GE.d11/ept5*width)THEN
!
!                       height governs the scale
!
   sxy=scale*d8/height
   xo=scale*pt5*(ept5-d8*width/height)
   yo=scale*opt5
 ELSE
!
!                       width governs the scale
!
   sxy=scale*fpt5/width
   xo=scale*opt5
   yo=scale*pt5*(d11-fpt5*height/width)
 END IF
!
!
!                       start PostScript output
!
 WRITE(ips,'(a)')'%!PS-Adobe-1.0'
 WRITE(ips,'(a)')'%%DocumentFonts: none'
 WRITE(ips,'(a)')'%%Pages: 1'
 WRITE(ips,'(a)')'%%EndComments'
 WRITE(ips,'(a)')'/m {moveto} def'
 WRITE(ips,'(a)')'/l {lineto} def'
 WRITE(ips,'(a)')'/s {stroke} def'
 WRITE(ips,'(a)')'/c {closepath} def'
 WRITE(ips,'(a)')'%%EndProlog'
 WRITE(ips,'(a)')'%%Page: 0 1'
 WRITE(ips,'(a)')'gsave'
!
!                       draw the deformed mesh
!
 WRITE(ips,'(2f9.2,a)') xo, yo, ' translate'
 WRITE(ips,'(f9.2,a)') 0.5, ' setlinewidth'

 wnew=loads(nf(1,1))

 DO i=1,nels
    DO j=1,interp

    wold=wnew
    localx=j*ell(i)/interp
    globalx=localx+xcoord(i)
    ll=ell(i)
    na=(one/(ll**3))*(ll**3-thr*ll*localx**2+two*localx**3)
    nb=(one/(ll**2))*(localx*ll**2-two*ll*localx**2+localx**3)
    nc=(one/(ll**3))*(thr*ll*localx**2-two*localx**3)
    nd=(one/(ll**2))*(localx**3-ll*localx**2)
    wnew=na*loads(nf(1,i))+nb*loads(nf(2,i))+nc*loads(nf(1,1+i))+nd*loads(nf(2,i+1))

    x=sxy*((globalx-ell(i)/interp)-xmin)
    y=sxy*(dismag*wold-ymin)
    WRITE(ips,'(2f9.2,a)') x, y,' m'
    x=sxy*(globalx-xmin)
    y=sxy*(dismag*wnew-ymin)
    WRITE(ips,'(2f9.2,a)') x, y,' l'
    WRITE(ips,'(a)')'c s'

    END DO

 END DO
!
 WRITE(ips,'(a)')'grestore'
 WRITE(ips,'(a)')'showpage'
 CLOSE(ips)
!
RETURN
END SUBROUTINE beamdis


text:
This is a page for recording photographs, stories, and experiences from the 2008 Whole Earth Festival.

20080510 16:45:02 nbsp we went late morning/early afternoon, and it didnt seem nearly as busy or patronized as it has in years past. There were significantly less vendors there than I remembered, and the crowds werent very big. Users/ElleWeber

20080510 19:17:04 nbsp I was there at about 2 pm on Saturday and it was busy as all heck. Lines everywhere and really hard to move around through the vendors shops. I was impressed at the amount of people and how well it was planned :) Users/BrandonBarrette

20080510 21:44:10 nbsp This year I learned my lesson... if you want to beat the crowds, go Friday! Users/OscarSabino

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

! compute mean and/or variance and/or correlation of a grid of data over one of the two indices
! row index is called "bins", column index is called "time"

module mean_var_correl_util_mod
use system_module
implicit none

contains

subroutine calc_correl(data, n_bins, n_data, over_bins, correlation_max_lag, correlation_subtract_mean, data_correl)
   real(dp) :: data(:,:)
   integer :: n_bins, n_data
   logical :: over_bins
   integer :: correlation_max_lag
   logical :: correlation_subtract_mean
   real(dp), allocatable :: data_correl(:,:)

   real(dp), allocatable :: data_mean(:)

   integer :: i, i_lag

    if (allocated(data_correl)) deallocate(data_correl)
    if (over_bins) then
      allocate(data_mean(size(data,2)))
      data_mean = sum(data,1)/real(size(data,1),dp)
      allocate(data_correl(min(n_bins, correlation_max_lag+1), n_data))
      data_correl = 0.0_dp
      if (correlation_subtract_mean) then
        do i_lag=0, min(n_bins-1, correlation_max_lag)
          do i=1, n_bins-i_lag
            data_correl(i_lag+1, :) = data_correl(i_lag+1, :) + (data(i,:)-data_mean(:))*(data(i+i_lag,:)-data_mean(:))
          end do
          data_correl(i_lag+1, :) = data_correl(i_lag+1, :) / real(n_bins-i_lag, dp)
        end do
      else
        do i_lag=0, min(n_bins-1, correlation_max_lag)
          do i=1, n_bins-i_lag
            data_correl(i_lag+1, :) = data_correl(i_lag+1, :) + (data(i,:))*(data(i+i_lag,:))
          end do
          data_correl(i_lag+1, :) = data_correl(i_lag+1, :) / real(n_bins-i_lag, dp)
        end do
      endif
    else ! over bins false
      allocate(data_mean(size(data,1)))
      data_mean = sum(data,2)/real(size(data,2),dp)
      allocate(data_correl(n_bins, min(correlation_max_lag+1,n_data)))
      data_correl = 0.0_dp
      if (correlation_subtract_mean) then
        do i_lag=0, min(n_data-1, correlation_max_lag)
          do i=1, n_data-i_lag
            data_correl(:, i_lag+1) = data_correl(:, i_lag+1) + (data(:,i)-data_mean(:))*(data(:,i+i_lag)-data_mean(:))
          end do
          data_correl(:, i_lag+1) = data_correl(:, i_lag+1) / real(n_data-i_lag, dp)
        end do
      else
        do i_lag=0, min(n_data-1, correlation_max_lag)
          do i=1, n_data-i_lag
            data_correl(:, i_lag+1) = data_correl(:, i_lag+1) + (data(:,i))*(data(:,i+i_lag))
          end do
          data_correl(:, i_lag+1) = data_correl(:, i_lag+1) / real(n_data-i_lag, dp)
        end do
      endif
    endif
    deallocate(data_mean)
end subroutine

! effective N_ind samples from autocorrelation variance
subroutine calc_correlation_var_effective_N(data_correl, over_bins, correlation_var_effective_N_long_lag, effective_N)
   real(dp) :: data_correl(:,:)
   logical :: over_bins
   integer :: correlation_var_effective_N_long_lag
   real(dp) :: effective_N(:)

   real(dp) :: correl_0, correl_mean, correl_std_dev
   integer :: i

   if (over_bins) then
     if (correlation_var_effective_N_long_lag+1 < size(data_correl,1)) then
       do i=1, size(data_correl,2)
         correl_0 = data_correl(1, i)
         correl_mean = sum(data_correl(correlation_var_effective_N_long_lag+1:,i)) / real(size(data_correl,1)-correlation_var_effective_N_long_lag, dp)
         correl_std_dev = sqrt( sum((data_correl(correlation_var_effective_N_long_lag+1:,i)-correl_mean)**2) / real(size(data_correl,1)-correlation_var_effective_N_long_lag, dp) )
         if (correl_std_dev > 1.0e-8_dp) then
           effective_N(i) = (correl_0/correl_std_dev)**2
         else
           effective_N(i) = -1
         endif
       end do
     endif ! long_lag short enough
   else ! over_bins false
     if (correlation_var_effective_N_long_lag+1 < size(data_correl,2)) then
       do i=1, size(data_correl,1)
         correl_0 = data_correl(i, 1)
         correl_mean = sum(data_correl(i,correlation_var_effective_N_long_lag+1:)) / real(size(data_correl,2)-correlation_var_effective_N_long_lag, dp)
         correl_std_dev = sqrt( sum((data_correl(i,correlation_var_effective_N_long_lag+1:)-correl_mean)**2) / real(size(data_correl,2)-correlation_var_effective_N_long_lag, dp) )
         if (correl_std_dev > 1.0e-8_dp) then
           effective_N(i) = (correl_0/correl_std_dev)**2
         else
           effective_N(i) = -1
         endif
         call print(" i " // i // " correl_0 " // correl_0 // " mean " // correl_mean // " std_dev " // correl_std_dev // " eff_N " // effective_N(i), verbosity=PRINT_VERBOSE)
       end do
     endif ! long_lag short enough
   endif  ! over_bins
end subroutine

! effective N_ind samples from summed ac, a la Sokal
subroutine calc_summed_ac_effective_N(N, data_correl, over_bins, max_lag, effective_N)
   integer :: N
   real(dp) :: data_correl(:,:)
   logical :: over_bins
   integer :: max_lag
   real(dp) :: effective_N(:)

   real(dp) :: correl_0, two_tau_int
   integer :: i

   if (over_bins) then
    do i=1, size(data_correl,2)
      correl_0 = data_correl(1, i)
      two_tau_int = 1.0_dp + 2.0_dp*sum(data_correl(2:max_lag+1,i))/correl_0
      effective_N(i) = real(N,dp)/two_tau_int
      call print("summed_ac i " // i // " correl_0 " // correl_0 // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE)
    end do
   else ! over_bins false
    do i=1, size(data_correl,1)
      correl_0 = data_correl(i, 1)
      two_tau_int = 1.0_dp + 2.0_dp*sum(data_correl(i,2:max_lag+1))/correl_0
      effective_N(i) = real(N,dp)/two_tau_int
      call print("summed_ac i " // i // " correl_0 " // correl_0 // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE)
    end do
   endif  ! over_bins
end subroutine

function calc_c_hat(data, k) result(c_hat)
   real(dp) :: data(:)
   integer :: k
   real(dp) :: c_hat

   real(dp)  :: sum_0, sum_k, sum_sq_0, sum_sq_k, cross_covar
   real(dp) :: N_minus_k
   integer :: N

   N = size(data)
   sum_0 = sum(data(1:N-k))
   sum_k = sum(data(1+k:N))
   sum_sq_0 = sum(data(1:N-k)**2)
   sum_sq_k = sum(data(1+k:N)**2)
   cross_covar = sum(data(1:N-k)*data(1+k:N))
   N_minus_k = real(N-k,dp)

   c_hat = ( cross_covar/N_minus_k - sum_0*sum_k/N_minus_k**2 ) / &
           ( sqrt(sum_sq_0 - (sum_0**2)/N_minus_k)* &
             sqrt(sum_sq_k - (sum_k**2)/N_minus_k) / (N_minus_k-1.0_dp) )
end function

! effective N_ind samples from summed ac, a la Kerl
subroutine calc_sliding_window_effective_N(data, over_bins, max_k, effective_N)
   real(dp) :: data(:,:)
   logical :: over_bins
   integer :: max_k
   real(dp) :: effective_N(:)

   real(dp), allocatable :: c_hat(:)
   real(dp) :: two_tau_int
   integer :: i, k

   ! John Kerl Ph.D. Thesis
   allocate(c_hat(1:max_k))

   if (over_bins) then
    do i=1, size(data,2)
      do k=1, max_k
         c_hat(k) = calc_c_hat(data(:,i),k)
         call print("c_hat " // k // " " // c_hat(k)//" "//(1.0_dp+2.0_dp*sum(c_hat(1:k))), verbosity=PRINT_VERBOSE)
      end do
      two_tau_int = 1.0_dp + 2.0_dp*sum(c_hat)
      effective_N(i) = real(size(data,1),dp)/two_tau_int
      call print(" i " // i // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE)
    end do
   else ! over_bins false
    do i=1, size(data,1)
      do k=1, max_k
         c_hat(k) = calc_c_hat(data(i,:),k)
         call print("c_hat " // k // " " // c_hat(k)//" "//(1.0_dp+2.0_dp*sum(c_hat(1:k))), verbosity=PRINT_VERBOSE)
      end do
      two_tau_int = 1.0_dp + 2.0_dp*sum(c_hat)
      effective_N(i) = real(size(data,2),dp)/two_tau_int
      call print(" i " // i // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE)
    end do
   endif  ! over_bins

   deallocate(c_hat)
end subroutine

! effective N_ind samples from binning (blocking), a la Hartman
subroutine calc_binning_effective_N(data, over_bins, effective_N)
   real(dp) :: data(:,:)
   logical :: over_bins
   real(dp) :: effective_N(:)

   real(dp) :: bin_size_d
   integer :: i, bin_size, N
   real(dp) :: err_est, prev_err_est, best_err_est, mean, means_variance_1

   if (over_bins) then
      do i=1, size(data,2)
         N = size(data,1)
         err_est=0.0_dp
         best_err_est = -1.0_dp
         bin_size_d = 1
         do while (bin_size_d > 0 .and. bin_size_d <= N/5)
            bin_size = bin_size_d

            prev_err_est = err_est
            err_est = binned_err_estimator(data(:,i),bin_size)

            if (err_est < prev_err_est .and. abs(err_est-prev_err_est)/(0.5_dp*(err_est+prev_err_est)) < 0.1_dp) best_err_est = err_est
            call print("binning_effective_N " // bin_size//" "//err_est, verbosity=PRINT_VERBOSE)
            bin_size_d = bin_size_d * 2
         end do
         call print("", verbosity=PRINT_VERBOSE)

         if (best_err_est < 0.0_dp) best_err_est = prev_err_est

         mean = sum(data(:,i))/real(N,dp)
         means_variance_1 = sum((data(:,i)-mean)**2)/real(N,dp)
         effective_N(i) = means_variance_1/best_err_est**2
         if (effective_N(i) > N) effective_N(i) = N
      end do
   else
      do i=1, size(data,1)
         N = size(data,2)
         err_est=0.0_dp
         best_err_est = -1.0_dp
         bin_size_d = 1
         do while (bin_size_d > 0 .and. bin_size_d <= N/5)
            bin_size = bin_size_d

            prev_err_est = err_est
            err_est = binned_err_estimator(data(i,:),bin_size)

            if (err_est < prev_err_est .and. abs(err_est-prev_err_est)/(0.5_dp*(err_est+prev_err_est)) < 0.1_dp) best_err_est = err_est
            call print("binning_effective_N " // bin_size//" "//err_est, verbosity=PRINT_VERBOSE)
            bin_size_d = bin_size_d * 2
         end do
         call print("", verbosity=PRINT_VERBOSE)

         if (best_err_est < 0.0_dp) best_err_est = prev_err_est

         mean = sum(data(i,:))/real(N,dp)
         means_variance_1 = sum((data(i,:)-mean)**2)/real(N,dp)
         effective_N(i) = means_variance_1/best_err_est**2
         if (effective_N(i) > N) effective_N(i) = N
      end do
   end if
end subroutine

function binned_err_estimator(data, bin_size) result(err_est)
   real(dp) :: data(:)
   integer :: bin_size
   real(dp) :: err_est

   integer :: n_bins, bin_i, N
   real(dp), allocatable :: means(:)
   real(dp) :: means_mean, means_variance

   N = size(data)
   n_bins = N/bin_size
   allocate(means(n_bins))

   do bin_i=1, n_bins
      means(bin_i) = sum(data((bin_i-1)*bin_size+1:bin_i*bin_size))/real(bin_size,dp)
   end do
   means_mean = sum(means)/real(n_bins,dp)
   means_variance = sum((means-means_mean)**2)/real(n_bins,dp)
   err_est = sqrt(means_variance/real(n_bins,dp))

   deallocate(means)
end function

end module mean_var_correl_util_mod

program mean_var_correl
use libatoms_module
use mean_var_correl_util_mod
implicit none
  integer :: n_bins, n_data, n_weights, i, j, bin_i, skip, max_frame
  logical :: do_weights
  real(dp), allocatable :: data(:,:), weights(:), data_line(:), data_t(:,:), weights_t(:), weighted_data(:,:)
  integer :: stat, new_data_array_size
  character(len=128), allocatable :: bin_labels(:)
  type(Dictionary) :: cli_params, data_params
  logical :: do_mean, do_var, do_histogram, do_correl, correlation_subtract_mean, do_correlation_var_effective_N, do_summed_ac_effective_N, do_sliding_window_effective_N, do_binning_effective_N, do_exp_smoothing
  logical :: do_bimod
  real(dp) :: exp_smoothing_time
  integer :: exp_smoothing_bin_i
  integer :: histogram_n_bins
  real(dp) :: histogram_min_v, histogram_max_v, histogram_cur_min_v, histogram_cur_max_v, histogram_extra_width, histogram_bin_width
  logical :: do_histogram_effective_N, do_histogram_correl
  character(len=STRING_LENGTH) :: infile_name, outfile_name
  character(len=102400) :: myline
  type(inoutput) :: infile, outfile
  real(dp), allocatable :: data_mean(:), data_var(:), data_correl(:,:), data_histogram(:,:,:), data_histogram_data(:,:,:), data_histogram_correl(:,:)
  real(dp), allocatable :: data_bimod(:), data_3_mom(:), data_4_mom(:)
  real(dp), allocatable :: smooth_data_v(:)
  integer :: reduction_index, other_index, sz, r_sz, correlation_max_lag, n_correl_print, correlation_var_effective_N_long_lag, sliding_window_effective_N_max_k, summed_ac_effective_N_max_lag
  logical :: over_bins, over_time
  real(dp), allocatable :: correlation_var_effective_N(:), summed_ac_effective_N(:), sliding_window_effective_N(:), binning_effective_N(:), histogram_effective_N(:,:)
  character(len=STRING_LENGTH) :: verbosity_str

  call system_initialise()

  call initialise(cli_params)
  call param_register(cli_params, "infile", "stdin", infile_name, help_string="input filename")
  call param_register(cli_params, "outfile", "stdout", outfile_name, help_string="output filename")
  call param_register(cli_params, "skip", "0", skip, help_string="skip this many initial frames")
  call param_register(cli_params, "max_frame", "0", max_frame, help_string="stop at this frame. if 0, continue until end")
  call param_register(cli_params, "mean", "F", do_mean, help_string="calculate mean")
  call param_register(cli_params, "exp_smoothing", "F", do_exp_smoothing, help_string="calculate exponentially smoothed data")
  call param_register(cli_params, "exp_smoothing_time", "100", exp_smoothing_time, help_string="time constant for exponential smoothing (in units of frames). 0 => no smoothing")
  call param_register(cli_params, "exp_smoothing_bin_i", "0", exp_smoothing_bin_i, help_string="bin to evaluate for exponential smoothing")
  call param_register(cli_params, "variance", "F", do_var, help_string="calculate variance")
  call param_register(cli_params, "bimodality", "F", do_bimod, help_string="calculate Sarle's bimodality coefficient")
  call param_register(cli_params, "correlation_var_effective_N", "F", do_correlation_var_effective_N, help_string="calculate effective N from ratio of initial variance to long time autocorrelation variance")
  call param_register(cli_params, "correlation_var_effective_N_long_lag", "1001", &
    correlation_var_effective_N_long_lag, help_string="lag after which autocorrelation is assumed to be in long time regime (for effective_N calculation)")
  call param_register(cli_params, "summed_ac_effective_N", "F", do_summed_ac_effective_N, help_string="calculate Sokals's summed_ac \tau_{int} based effective N from integrated autocorrelation")
  call param_register(cli_params, "summed_ac_effective_N_max_lag", "1001", &
    summed_ac_effective_N_max_lag, help_string="max lag to calculate autocorrelation estimator for summed_ac effective N")
  call param_register(cli_params, "sliding_window_effective_N", "F", do_sliding_window_effective_N, help_string="calculate Kerl's sliding_window \tau_{int} based effective N from fancy integrated autocorrelation")
  call param_register(cli_params, "sliding_window_effective_N_max_k", "1001", &
    sliding_window_effective_N_max_k, help_string="max lag to calculate autocorrelation estimator for sliding window effective N")
  call param_register(cli_params, "binning_effective_N", "F", do_binning_effective_N, help_string="calculate binning effective N")
  call param_register(cli_params, "correlation", "F", do_correl, help_string="calculate autocorrelation")
  call param_register(cli_params, "correlation_subtract_mean", "T", correlation_subtract_mean, help_string="subtract mean before calculating autocorrelation")
  call param_register(cli_params, "correlation_max_lag", "2000", correlation_max_lag, help_string="maxmimum lag to compute autocorrelation for")
  call param_register(cli_params, "histogram", "F", do_histogram, help_string="compute histogram")
  call param_register(cli_params, "histogram_n_bins", "10", histogram_n_bins, help_string="number of bins for histogram calculation")
  call param_register(cli_params, "histogram_extra_width", "0.1", histogram_extra_width, help_string="extra range to do histogram over, in fractions of max_val-min_val (ignored if histogram_min,max_v are used)")
  call param_register(cli_params, "histogram_effective_N", "F", do_histogram_effective_N, help_string="if true calculate effective N for bins based on autocorrelation")
  call param_register(cli_params, "histogram_correl", "F", do_histogram_correl, help_string="if true calculate autocorrelation for histogram bins")
  call param_register(cli_params, "histogram_min_v", "0.0", histogram_min_v, help_string="minimum value to use for histogram range (if not specified, automatic)")
  call param_register(cli_params, "histogram_max_v", "-1.0", histogram_max_v, help_string="maximum value to use for histogram range (if not specified, automatic)")
  call param_register(cli_params, "over_bins", "F", over_bins, help_string="do mean/variance/correlation over bins")
  call param_register(cli_params, "over_time", "F", over_time, help_string="do mean/variance/correlation over time")
  call param_register(cli_params, "verbosity", "NORMAL", verbosity_str, help_string="verbosity level")
  if (.not.param_read_args(cli_params)) then
    call print("Usage: "//trim(EXEC_NAME)//" infile=stdin outfile=stdout mean=F variance=F correlation=F effective_N=F", PRINT_ALWAYS)
    call print("        correlation_max_lag=1000 correlation_var_effective_N_long_lag=1001 over_bins=F over_time=T", PRINT_ALWAYS)
    call system_abort("Unable to parse command line")
  endif
  call finalise(cli_params)

  if (over_bins .and. over_time) &
    call system_abort("specified both over_bins="//over_bins//" over_time="//over_time)

  call verbosity_push(verbosity_of_str(trim(verbosity_str)))

  if (.not. over_bins .and. .not. over_time) then
    over_bins = .false.
    over_time = .true.
  endif

  if (over_bins) then
    reduction_index = 1
    other_index = 2
  else
    reduction_index = 2
    other_index = 1
  endif

  call initialise(data_params)
  call param_register(data_params, "n_bins", param_mandatory, n_bins, help_string="number of bins at each data timepoint")
  call param_register(data_params, "n_data", '-1', n_data, help_string="number of data timepoints, < 0 to figure out from length of file")
  call param_register(data_params, "do_weights", 'F', do_weights, help_string="If true, do weighted mean")

  call initialise(infile, infile_name, INPUT)
  myline=read_line(infile) ! comment
  myline=read_line(infile) ! data description
  if (.not.param_read_line(data_params, trim(myline), ignore_unknown=.false.)) &
    call system_abort("Couldn't parse n_bins or n_data in 2nd line of file")

  if (do_weights) then
    if (over_bins) call system_abort("Can't do weighted mean over bins")
    n_weights = 1
  else
    n_weights = 0
  end if

  allocate(bin_labels(n_bins))
  do i=1, n_bins
    bin_labels(i) = read_line(infile)
  end do
  allocate(data_line(n_bins+n_weights))
  if(skip > 0) then
     do i=1,skip
        call read_ascii(infile, data_line(:))
     end do
     n_data = n_data-skip
  end if
  if (n_data > 0) then
      if(max_frame > 0 .and. max_frame <= n_data) then
         n_data = max_frame
      end if
      allocate(data(n_bins, n_data))
      if (n_weights > 0) then
        allocate(weights(n_data))
      endif
      do i=1, n_data
        call read_ascii(infile, data_line(:))
        if (n_weights > 0) then
            weights(i) = data_line(1)
            data(:,i) = data_line(2:)
        else
            data(:,i) = data_line(:)
        endif
      end do
  else ! n_data <= 0, figure out by reading
      print *, "doing n_data = 0"
      ! initial counters and storage
      n_data = 0
      allocate(data(n_bins,1))
      if (n_weights > 0) allocate(weights(1))
      ! read a line
      do while (.true.)
          call read_ascii(infile, data_line(:), stat)
          if (stat < 0 .or. (max_frame > 0 .and. n_data == max_frame)) then ! end
              ! if we have extra space, reallocate to precise space
              if (size(data,2) /= n_data) then
                  ! allocate temporary space
                  allocate(data_t(n_bins, n_data))
                  ! copy into temporary
                  data_t = data(:,1:n_data)
                  ! reallocate intended space to exact size
                  deallocate(data)
                  allocate(data(n_bins, n_data))
                  data = data_t
                  ! clear up temporary
                  deallocate(data_t)
                  ! do the same for weights
                  if (n_weights > 0) then
                      allocate(weights_t(n_data))
                      weights_t = weights(1:n_data)
                      deallocate(weights)
                      allocate(weights(n_data))
                      weights = weights_t
                      deallocate(weights_t)
                  endif
              endif
              exit ! from while loop
          elseif (stat == 0) then ! add this line
              ! if we don't have space for additional entry, reallocate it
              if (n_data >= size(data,2)) then
                ! allocate temporary space
                allocate(data_t(n_bins,n_data))
                data_t = data
                deallocate(data)
                new_data_array_size = max(int(1.5*n_data),2)
                allocate(data(n_bins, new_data_array_size))
                data(1:n_bins,1:n_data) = data_t(:,:)
                deallocate(data_t)
                if (n_weights > 0) then
                    allocate(weights_t(n_data))
                    weights_t = weights
                    deallocate(weights)
                    allocate(weights(new_data_array_size))
                    weights(1:n_data) = weights_t(:)
                    deallocate(weights_t)
                endif
              endif
              ! add additional entry
              n_data = n_data + 1
              if (n_weights > 0) then
                  weights(n_data) = data_line(1)
                  data(:,n_data) = data_line(2:)
              else
                  data(:,n_data) = data_line(:)
              endif
          else ! real error
              call system_abort("Read error in data " // stat)
          endif
      end do ! while
  endif
  deallocate(data_line)
  print *, "final n_data", n_data

  sz = size(data, other_index)
  r_sz = size(data, reduction_index)

  call initialise(outfile, outfile_name, OUTPUT)

  allocate(data_mean(sz))
  if (n_weights > 0) then
      allocate(weighted_data(size(data,1),size(data,2)))
      do i=1, n_data
         weighted_data(:,i) = data(:,i) * weights(i)
      end do
      data_mean = sum(weighted_data,reduction_index) / sum(weights)
      deallocate(weighted_data)
  else
      data_mean = sum(data,reduction_index)/real(size(data,reduction_index),dp)
  endif

  if (do_var .or. do_bimod) then
    allocate(data_var(sz))
    if (over_bins) then
      do i=1, sz
        data_var(i) = sum((data(:,i)-data_mean(i))**2)/size(data,reduction_index)
      end do
    else
      if (n_weights > 0) then
          do i=1, sz
            data_var(i) = sum(weights(:)*(data(i,:)-data_mean(i))**2)/sum(weights)
          end do
       else
          do i=1, sz
            data_var(i) = sum((data(i,:)-data_mean(i))**2)/size(data,reduction_index)
          end do
       endif
    endif
  endif

  ! b = \frac{(\mu_3^2/\mu_2^3) + 1.0}{\mu_4/\mu_2^2},
  if (do_bimod) then
    allocate(data_bimod(sz))
    allocate(data_3_mom(sz))
    allocate(data_4_mom(sz))
    if (over_bins) then
      do i=1, sz
        data_3_mom(i) = sum((data(:,i)-data_mean(i))**3)/size(data,reduction_index)
        data_4_mom(i) = sum((data(:,i)-data_mean(i))**4)/size(data,reduction_index)
      end do
    else
      if (n_weights > 0) then
          do i=1, sz
            data_3_mom(i) = sum(weights(:)*(data(i,:)-data_mean(i))**3)/sum(weights)
            data_4_mom(i) = sum(weights(:)*(data(i,:)-data_mean(i))**4)/sum(weights)
          end do
       else
          do i=1, sz
            data_3_mom(i) = sum((data(i,:)-data_mean(i))**3)/size(data,reduction_index)
            data_4_mom(i) = sum((data(i,:)-data_mean(i))**4)/size(data,reduction_index)
          end do
       endif
    endif
    data_bimod = ((data_3_mom**2 / data_var**3) + 1.0) / (data_4_mom/data_var**2)
    deallocate(data_3_mom, data_4_mom)
  endif

  if (do_correl .or. do_correlation_var_effective_N .or. do_summed_ac_effective_N) then
    call calc_correl(data, n_bins, n_data, over_bins, correlation_max_lag, correlation_subtract_mean, data_correl)

    if (do_correl) then
      call print("# correl", file=outfile)
      if (over_bins) then
        n_correl_print = n_data
      else
        n_correl_print = min(n_data, correlation_max_lag+1)
      endif
      do i=1, n_correl_print
        call print(""//data_correl(:,i), file=outfile)
      end do
    endif

    if (do_correlation_var_effective_N) then
      allocate(correlation_var_effective_N(sz))
      call calc_correlation_var_effective_N(data_correl, over_bins, correlation_var_effective_N_long_lag, correlation_var_effective_N)
    endif
    if (do_summed_ac_effective_N) then
      allocate(summed_ac_effective_N(sz))
      call calc_summed_ac_effective_N(size(data,reduction_index), data_correl, over_bins, summed_ac_effective_N_max_lag, summed_ac_effective_N)
    endif
  endif ! do_correl or do_effective_N
  if (do_sliding_window_effective_N) then
    allocate(sliding_window_effective_N(sz))
    call calc_sliding_window_effective_N(data, over_bins, sliding_window_effective_N_max_k, sliding_window_effective_N)
  endif
  if (do_binning_effective_N) then
    allocate(binning_effective_N(sz))
    call calc_binning_effective_N(data, over_bins, binning_effective_N)
  endif

  ! data(n_bins, n_data)
  if (do_exp_smoothing) then
    if (over_bins) then
      call system_abort("Can't actually do exponentially smoothed time trace over bins")
    else
      myline="# bin_label value"
      if (exp_smoothing_bin_i <= 0 .or. exp_smoothing_bin_i > n_bins) then
         call system_abort("exp_smoothing_bin_i out of range "//exp_smoothing_bin_i)
      endif
    endif
    call print(trim(myline), file=outfile)
    if (over_bins) then
      call system_abort("Can't actually do exponentially smoothed time trace over bins")
    else
       allocate(smooth_data_v(n_bins))
       smooth_data_v(1:n_bins) = data(1:n_bins, 1)
       call print(trim(bin_labels(exp_smoothing_bin_i))//" "//smooth_data_v(exp_smoothing_bin_i), file=outfile)
       do i=2, n_data
         if (exp_smoothing_time > 0.0_dp) then
            smooth_data_v(1:n_bins) = (1.0_dp - 1.0_dp/exp_smoothing_time)*smooth_data_v(1:n_bins) + 1.0_dp/exp_smoothing_time*data(1:n_bins, i)
         else
            smooth_data_v(1:n_bins) = data(1:n_bins, i)
         endif
         call print(trim(bin_labels(exp_smoothing_bin_i))//" "//smooth_data_v(exp_smoothing_bin_i), file=outfile)
       end do
    endif
  end if ! do_exp_smoothing

  if (do_mean .or. do_var .or. do_bimod .or. do_correlation_var_effective_N .or. do_summed_ac_effective_N .or. do_sliding_window_effective_N .or. do_binning_effective_N) then
    if (over_bins) then
      myline = "#"
    else
      myline = "# bin_label"
    endif
    if (do_mean) myline = trim(myline) //" mean"
    if (do_var) myline = trim(myline) //" var N"
    if (do_bimod) myline = trim(myline) //" bimod"
    if (do_correlation_var_effective_N) myline = trim(myline) // " correlation_var_effective_N correlation_var_effective_decorrel_time"
    if (do_summed_ac_effective_N) myline = trim(myline) // " summed_ac_effective_N summed_ac_effective_decorrel_time"
    if (do_sliding_window_effective_N) myline = trim(myline) // " sliding_window_effective_N sliding_window_effective_decorrel_time"
    if (do_binning_effective_N) myline = trim(myline) // " binning_effective_N binning_effective_decorrel_time"

    call print(trim(myline), file=outfile)

    do i=1, sz
      if (over_bins) then
        myline = ""
      else
        myline = trim(bin_labels(i))
      endif
      if (do_mean) myline = trim(myline) //" " // data_mean(i)
      if (do_var) myline = trim(myline) //" " // data_var(i)//" "//size(data,reduction_index)
      if (do_bimod) myline = trim(myline) //" " // data_bimod(i)
      if (do_correlation_var_effective_N) then
        if (correlation_var_effective_N(i) > 0) then
          myline = trim(myline) // " " // correlation_var_effective_N(i) // " " // (size(data,reduction_index)/correlation_var_effective_N(i))
        else
          myline = trim(myline) // " " // correlation_var_effective_N(i) // " " // 0
        endif
      endif
      if (do_summed_ac_effective_N) then
        if (summed_ac_effective_N(i) > 0) then
          myline = trim(myline) // " " // summed_ac_effective_N(i) // " " // (size(data,reduction_index)/summed_ac_effective_N(i))
        else
          myline = trim(myline) // " " // summed_ac_effective_N(i) // " " // 0
        endif
      endif
      if (do_sliding_window_effective_N) then
        if (sliding_window_effective_N(i) > 0) then
          myline = trim(myline) // " " // sliding_window_effective_N(i) // " " // (size(data,reduction_index)/sliding_window_effective_N(i))
        else
          myline = trim(myline) // " " // sliding_window_effective_N(i) // " " // 0
        endif
      endif
      if (do_binning_effective_N) then
        if (binning_effective_N(i) > 0) then
          myline = trim(myline) // " " // binning_effective_N(i) // " " // (size(data,reduction_index)/binning_effective_N(i))
        else
          myline = trim(myline) // " " // binning_effective_N(i) // " " // 0
        endif
      endif
      call print(trim(myline), file=outfile)
    end do
  end if

  if (do_histogram) then
    ! data(n_bins, n_data)
    allocate(data_histogram(3, histogram_n_bins, sz))
    if (do_histogram_effective_N) then
      allocate(data_histogram_data(histogram_n_bins, r_sz, sz))
      data_histogram_data = 0.0_dp
    endif
    data_histogram = 0.0_dp
    do i=1, sz
      if (histogram_max_v > histogram_min_v) then
         histogram_cur_min_v = histogram_min_v
         histogram_cur_max_v = histogram_max_v
      else
         if (over_bins) then
           histogram_cur_min_v = minval(data(:,i))
           histogram_cur_max_v = maxval(data(:,i))
         else
           histogram_cur_min_v = minval(data(i,:))
           histogram_cur_max_v = maxval(data(i,:))
         endif
         histogram_extra_width = (histogram_cur_max_v-histogram_cur_min_v)*histogram_extra_width
         histogram_cur_min_v = histogram_cur_min_v - histogram_extra_width
         histogram_cur_max_v = histogram_cur_max_v + histogram_extra_width
      endif
      histogram_bin_width = (histogram_cur_max_v-histogram_cur_min_v)/histogram_n_bins
      if (histogram_bin_width == 0.0_dp) histogram_bin_width = 1.0e-8_dp
      do bin_i=1, histogram_n_bins
        data_histogram(1, bin_i, i) = histogram_cur_min_v+(real(bin_i,dp)-0.5_dp)*histogram_bin_width
      end do
      do j=1, r_sz
        if (over_bins) then
          bin_i = (data(j,i) - histogram_cur_min_v)/histogram_bin_width+1
        else
          bin_i = (data(i,j) - histogram_cur_min_v)/histogram_bin_width+1
        endif
        if (bin_i >= 1 .and. bin_i <= histogram_n_bins) then
          data_histogram(2,bin_i,i) = data_histogram(2,bin_i,i) + 1.0_dp
          if (do_histogram_effective_N) then
             data_histogram_data(bin_i, j, i) = 1
          endif
        endif
      end do ! r_sz
    end do ! i
    data_histogram(2,:,:) = data_histogram(2,:,:)/real(r_sz, dp)
    ! root variance
    data_histogram(3,:,:) = sqrt(data_histogram(2,:,:) - data_histogram(2,:,:)**2)
    ! normalize
    data_histogram(2:3,:,:) = data_histogram(2:3,:,:)/histogram_bin_width
    if (do_histogram_effective_N) then
      allocate(histogram_effective_N(histogram_n_bins,sz))
      do i=1, sz
         call calc_correl(data_histogram_data(:,:,i), histogram_n_bins, n_data, .false., correlation_max_lag, .true., data_histogram_correl)
         if (do_histogram_correl) then
            do bin_i=1, histogram_n_bins
               call print("# data_histogram_correl i="//i // " bin=" // bin_i)
               do j=1, size(data_histogram_correl,2)
                  call print(data_histogram_correl(bin_i,j))
               end do
               call print("")
               call print("")
            end do
         endif
         mainlog%prefix="EFF_N value_i="//i
         call calc_correlation_var_effective_N(data_histogram_correl, .false., correlation_var_effective_N_long_lag, histogram_effective_N(:,i))
         mainlog%prefix=""
      end do
    endif

    if (do_histogram_effective_N) then
       call print("# v p(v) rms(p(v)) effective_N", file=outfile)
    else
       call print("# v p(v) rms(p(v))", file=outfile)
    endif

    do i=1, sz
      if (over_bins) then
        myline = "#"
      else
        myline = "# "//trim(bin_labels(i))
      endif
      call print(trim(myline), file=outfile)
      do bin_i=1, histogram_n_bins
        if (do_histogram_effective_N) then
           call print(data_histogram(:,bin_i,i)//" "//histogram_effective_N(bin_i,i), file=outfile)
        else
           call print(data_histogram(:,bin_i,i), file=outfile)
        endif
      end do
      call print("", file=outfile)
      call print("", file=outfile)
    end do
  end if ! do_histogram

  call finalise(outfile)
  call system_finalise()

end program

max_stars_repo_name: Sideboard/QUIP

max_issues_repo_name: Sideboard/QUIP

max_forks_repo_name: Sideboard/QUIP


text:
EB games is a Videogaming video game store in Davis.  They sell new and used games (PC and Console), systems, and accessories. They will also buy your used videogames for cash or instore credit, but dont expect to get much. They also have DDR pads so you can play at home.  Additionally, they sell games for older systems like Gameboy and Gameboy Color, but appear to no longer be selling Dreamcast, PSX, N64, Genesis, or NES titles.  They claim they have no Apple Mac games for sale, unless they are selling a PC game that has builtin Mac support.  For $6, you can buy an EB Edge card that gives you 10% all used dvds and video games.  The service lasts for one year (from date of purchase of the card).

They celebrate Wintereenmas, offering sales during the holiday.

Gamestop bought EB Games in 2005.  They probably wont be changing anything until mid 2006.

EDIT:: As of June 2007, theyve put up a new sign and now its a GameStop.


text:
      SUBROUTINE UFBRMS(IMSG,ISUB,USR,I1,I2,IRET,STR)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    UFBRMS
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES OUT OF A PARTICULAR
C   SUBSET WHICH HAS BEEN READ INTO INTERNAL SUBSET ARRAYS FROM A
C   PARTICULAR BUFR MESSAGE IN INTERNAL MEMORY.  THE DATA VALUES
C   CORRESPOND TO MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION
C   SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL. THE SUBSET
C   READ IN IS BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE
C   MESSAGE READ IN IS BASED ON THE MESSAGE NUMBER IN INTERNAL MEMORY.
C   THIS SUBROUTINE IS ACTUALLY A COMBINATION OF BUFR ARCHIVE LIBRARY
C   SUBROUTINES RDMEMM, RDMEMS AND UFBINT.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C                           ROUTINE "BORT"
C 1999-11-18  J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO
C                           STORE ALL MESSAGES INTERNALLY WAS INCREASED
C                           FROM 4 MBYTES TO 8 MBYTES
C 2001-08-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
C                           BYTES REQUIRED TO STORE ALL MESSAGES
C                           INTERNALLY) WAS INCREASED FROM 8 MBYTES TO
C                           16 MBYTES
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF
C                           BUFR MESSAGES WHICH CAN BE STORED
C                           INTERNALLY) INCREASED FROM 50000 TO 200000;
C                           UNIFIED/PORTABLE FOR WRF; ADDED
C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
C                           HAPPEN
C 2004-11-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
C                           BYTES REQUIRED TO STORE ALL MESSAGES
C                           INTERNALLY) WAS INCREASED FROM 16 MBYTES TO
C                           50 MBYTES
C 2009-04-21  J. ATOR    -- USE ERRWRT
C 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C
C USAGE:    CALL UFBRMS (IMSG, ISUB, USR, I1, I2, IRET, STR)
C   INPUT ARGUMENT LIST:
C     IMSG     - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN
C                STORAGE
C     ISUB     - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR
C                MESSAGE
C     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT
C                LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED
C                MNEMONICS IN STR)
C     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF USR
C     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
C                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
C                DIMENSION OF USR {THIS CAN ALSO BE A SINGLE TABLE D
C                (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED
C                REPLICATION (SEE REMARKS 1 IN UFBINT DOCBLOCK)}
C
C   OUTPUT ARGUMENT LIST:
C     USR      - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ
C                FROM DATA SUBSET
C     IRET     - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM
C                DATA SUBSET (MUST BE NO LARGER THAN I2)
C
C REMARKS:
C    NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR
C    MESSAGES INTO INTERNAL MEMORY.
C
C    THIS ROUTINE CALLS:        BORT     ERRWRT   RDMEMM   RDMEMS
C                               STATUS   UFBINT
C    THIS ROUTINE IS CALLED BY: None
C                               Normally called only by application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      USE MODA_MSGCWD
      USE MODA_MSGMEM

      INCLUDE 'bufrlib.prm'

      COMMON /QUIET / IPRT

      CHARACTER*(*) STR
      CHARACTER*128 BORT_STR,ERRSTR
      CHARACTER*8   SUBSET
      REAL*8        USR(I1,I2)

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      IRET = 0
      IF(I1.LE.0) THEN
         IF(IPRT.GE.0) THEN
      CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      ERRSTR = 'BUFRLIB: UFBRMS - 4th ARG. (INPUT) IS .LE. 0, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
      CALL ERRWRT(ERRSTR)
      CALL ERRWRT(STR)
      CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL ERRWRT(' ')
         ENDIF
         GOTO 100
      ELSEIF(I2.LE.0) THEN
         IF(IPRT.GE.0) THEN
      CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      ERRSTR = 'BUFRLIB: UFBRMS - 5th ARG. (INPUT) IS .LE. 0, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
      CALL ERRWRT(ERRSTR)
      CALL ERRWRT(STR)
      CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL ERRWRT(' ')
         ENDIF
         GOTO 100
      ENDIF

C  UFBINT SUBSET #ISUB FROM MEMORY MESSAGE #IMSG
C  ---------------------------------------------

      CALL RDMEMM(IMSG,SUBSET,JDATE,IRET)
      IF(IRET.LT.0) GOTO 900
      CALL RDMEMS(ISUB,IRET)
      IF(IRET.NE.0) GOTO 901

      CALL UFBINT(MUNIT,USR,I1,I2,IRET,STR)

C  EXITS
C  -----

100   RETURN
900   IF(IMSG.GT.0)  THEN
      WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE '//
     . 'NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN '//
     . 'MEMORY (",I5,")")') IMSG,MSGP(0)
      ELSE
      WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE '//
     . 'NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")')
      ENDIF
      CALL BORT(BORT_STR)
901   CALL STATUS(MUNIT,LUN,IL,IM)
      WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQ. SUBSET NUMBER TO READ '//
     . 'IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '//
     . 'REQ. MEMORY MESSAGE (",I5,")")') ISUB,MSUB(LUN),IMSG
      CALL BORT(BORT_STR)
      END


text: >Classical Music Performances in In C Major Davis<


text:
!==============================================================================!
  subroutine Grid_Mod_Bnd_Cond_Ranges(grid)
!------------------------------------------------------------------------------!
!   Allocates memory and finds the range (first and last boundary cell)        !
!   for each of the boundary condition colors.                                 !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer :: c, color
!==============================================================================!

  ! Allocate memory
  allocate(grid % bnd_cond % color_f(grid % n_bnd_cond))
  allocate(grid % bnd_cond % color_l(grid % n_bnd_cond))

  ! Set non-realizable ranges
  grid % bnd_cond % color_f(:) = -1
  grid % bnd_cond % color_l(:) =  0

  ! Browse forward and backward to find first and last cell for each range
  do c = -1, -grid % n_bnd_cells, -1
    color = grid % bnd_cond % color(c)
    if(c < grid % bnd_cond % color_l(color)) then
      grid % bnd_cond % color_l(color) = c
    end if
  end do
  do c = -grid % n_bnd_cells, -1
    color = grid % bnd_cond % color(c)
    if(c > grid % bnd_cond % color_l(color)) then
      grid % bnd_cond % color_f(color) = c
    end if
  end do

  end subroutine

max_stars_repo_name: MassimoBorrelliPhysicist/T-Flows

max_issues_repo_name: MassimoBorrelliPhysicist/T-Flows

max_forks_repo_name: MassimoBorrelliPhysicist/T-Flows


text:
	SUBROUTINE RU_WIND  ( field, wnknot, dir, spd, iret )
C************************************************************************
C* RU_WIND								*
C*									*
C* This subroutine decodes a wind field in the form ddfff where dd	*
C* is the direction in tens of degrees and fff is the wind speed.	*
C* The units value of the direction rounded to the nearest 5 degrees	*
C* has been multiplied by 100 and added to fff.				*
C*									*
C* RU_WIND  ( FIELD, WNKNOT, DIR, SPD, IRET )				*
C*									*
C* Input parameters:							*
C*	FIELD		CHAR*		Encoded field			*
C*	WNKNOT		LOGICAL		Speed in knots flag		*
C*									*
C* Output parameters:							*
C*	DIR		REAL		Direction			*
C*	SPD		REAL		Speed in meters/sec		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/86						*
C* D. Kidwell/NCEP	 3/01	Added check for '31313'                 *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	field
	LOGICAL		wnknot
C------------------------------------------------------------------------
	iret = 0
C*
	dir = RMISSD
	spd = RMISSD
C
C*	The tens and hundreds of the wind direction is encoded in the
C*	first two digits.  Skip processing if direction is missing.
C
	CALL ST_INTG  ( field (1:2), idir, ier )
	IF  ( ier .ne. 0 )  THEN
	    RETURN
	  ELSE
	    idir = idir * 10
	END IF
C
C*	The wind speed is encoded in the last three digits.
C
	CALL ST_INTG  ( field (3:5), ispd, ier )
	IF  ( ier .ne. 0 )  THEN
	    RETURN
	  ELSE
C
C*	    The units value of the direction rounded to 0 or 5 is
C*	    multiplied by 100 and added to the wind speed.
C
	    IF  ( ispd .ge. 500 )  THEN
		ispd = ispd - 500
		idir = idir + 5
	    END IF
	END IF
C
C*	Set the output values.  Return missing data if direction is
C*	greater than 360 or field is '31313'.
C
	IF ( ( idir .le. 360 ) .and. ( field (1:5) .ne. '31313' ) ) THEN
	    spd = FLOAT ( ispd )
	    IF ( wnknot ) spd = PR_KNMS ( spd )
	    dir = FLOAT ( idir )
	    IF  ( dir .eq. 360. ) dir = 0.
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak