text:
      subroutine gdlgxw(cdrs,cjbasp,cnufac,conc,dlogxw,eps100,
     $ ixbasp,jcsort,jflag,narn1,narn2,nbasp,nbt,nbtmax,nbw,
     $ ndrs,ndrsmx,ndrsr,nern1,nern2,noutpt,nstmax,nttyo,omega,
     $ xbar,xbarw)
c
c     This subroutine computes the array dlogxw, which contains the
c     partial derivatives:
c
c       d log x(w)/d log m(s')
c
c     where s' denotes a basis species other than water. Allowed
c     basis species may be aqueous or generic ion exchanger species.
c
c     This subroutine is called by:
c
c       EQLIB/matrix.f
c       EQ3NR/arrsim.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nbtmax,ndrsmx,nstmax
c
      integer noutpt,nttyo
c
      integer ixbasp(nbtmax),jcsort(nstmax),jflag(nstmax),nbasp(nbtmax),
     $ ndrs(ndrsmx),ndrsr(2,nstmax)
      integer narn1,narn2,nbt,nbw,nern1,nern2
c
      real*8 cdrs(ndrsmx),cjbasp(nbtmax),cnufac(nstmax),conc(nstmax),
     $ dlogxw(nbtmax),xbar(nstmax)
      real*8 eps100,omega,xbarw
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer nb,nsc,nse,nss
c
      real*8 cw,cxec,dx,sumw,xx
c
      real*8 coefdr
c
c-----------------------------------------------------------------------
c
      if (nbw .eq. 0) then
        write (noutpt,1000)
        write (nttyo,1000)
 1000   format(/' * Error - (EQLIB/dxlgxw) Programming error trap:',
     $  /7x,'Water is not in the basis set, so the dlogxw array',
     $  /7x,'should not be calculated.')
        stop
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Make sure that the "conc" of water is zero. This will be restored
c     at the end of this subroutine. This practice allows avoiding "if"
c     testing in the following loops. Note that there is no actual
c     element of the dlogxw array for water (basis index nbw). However,
c     there is a sum used in the denominator of the other array elements
c     that is based on water, and this resembles the sums accumulated
c     for the other elements. Therefore, dlogxw(nbw) will be used here
c     to accumulate that sum. It will be reset to zero after the sum
c     is used.
c
      cw = conc(narn1)
      conc(narn1) = 0.
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute the sums needed to calculate the dlogxw array.
c     Store them in this array.
c
      do nb = 1,nbt
        nse = nbasp(nb)
        dlogxw(nb) = conc(nse)
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      do nss = narn1,narn2
        nsc = jcsort(nss)
        if (jflag(nsc) .eq. 30) then
c
          do nb = 1,nbt
            nse = nbasp(nb)
c
c           Calling sequence substitutions:
c             nsc for ns
c
            cxec = coefdr(cdrs,ndrs,ndrsmx,ndrsr,nse,nsc,nstmax)
c
c           Here cnufac(nsc) = -conc(nsc)/cdrs(ndrsr(1,nsc)), or
c           the negative of the molality of a dependent species
c           divided by its (intrinsically negative) reaction
c           coefficient in its associated reaction.
c
            dlogxw(nb) = dlogxw(nb) + cxec*cnufac(nsc)
          enddo
        endif
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute the dlogxw array from the sums. The common denominator
c     (dx) for the elements corresponding to basis species other than
c     water is computed from the sum for water.
c
c     Do not protect here against a value of xbarw that is ridiculously
c     small, say on the order of 1.e-30. Such a value seems to be
c     necessary to obtaining good results in pre-Newton-Raphson
c     optimization. Only protect against a zero divide below, where
c     dx (derived from xbarw) appears in a denominator.
c
      xx = xbarw/omega
      sumw = dlogxw(nbw)
      dlogxw(nbw) = 0.
      dx = 1. + xx*sumw
c
c     Protect against the case in which dx is zero. This is designed
c     to prevent a fatal floating point exception in pre-Newton-Raphson
c     optimization.
c
      if (dx.ge.0. .and.  dx.lt.eps100) dx = eps100
      if (dx.lt.0. .and.  dx.gt.-eps100) dx = -eps100
c
      do nb = 1,nbt
        if (nb .ne. nbw) then
          dlogxw(nb) = -xx*dlogxw(nb)/dx
          if (ixbasp(nb) .ge. 1) then
c
c           Here nb refers to a basis species whose thermodynamic
c           activity is defined by its mole fraction.
c
            nse = nbasp(nb)
            dlogxw(nb) = dlogxw(nb)*cjbasp(nb)*(1.0 - xbar(nse))
          endif
        endif
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Restore the "conc" of water.
c
      conc(narn1) = cw
c
      end

ext: f


text:
program initialization_test
    implicit none
    integer, parameter :: n = 5
    integer :: i

    print '(A1, 2A10)', 'n', 'wrong', 'right'
    do i = 0, n
        print '(I1, 2I10)', i, factorial_bad(i), factorial_good(i)
    end do

contains

    function factorial_bad(n) result(f)
        implicit none
        integer, intent(in) :: n
        integer :: f
        integer :: fac = 1, i
        do i = 2, n
            fac = fac*i
        end do
        f = fac
    end function factorial_bad

    function factorial_good(n) result(f)
        implicit none
        integer, intent(in) :: n
        integer :: f
        integer :: fac, i
        fac = 1
        do i = 2, n
            fac = fac*i
        end do
        f = fac
    end function factorial_good

end program initialization_test

max_stars_repo_name: Gjacquenot/training-material

max_issues_repo_name: Gjacquenot/training-material

max_forks_repo_name: Gjacquenot/training-material


text:
subroutine incsdu(timhr  ,dps  ,s1  ,kcs  ,kfs,  gdp    )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: incsdu.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/timedep/incsdu.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Determine increments and update the current time
!              dependent value for subsidence/uplift data (if lfsdu
!              = true)
! Method used: At each time step (if lfsdu=true) the difference between the
!              values at the previous call are added to the depth values
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use meteo
    use dfparall
    use precision
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    logical               , pointer :: sdufirst
    logical               , pointer :: lfsdus1
    integer               , pointer :: itdate
    real(fp)              , pointer :: tzone
    real(fp), dimension(:), pointer :: sdu_t0
    real(fp), dimension(:), pointer :: sdu_tn
    real(fp), dimension(:), pointer :: sdu_tp
!
! Global variables
!
    real(fp)                                      , intent(in)  :: timhr
    real(fp)    , dimension(gdp%d%nmlb:gdp%d%nmub)              :: dps    !  Description and declaration in esm_alloc_real.f90
    real(fp)    , dimension(gdp%d%nmlb:gdp%d%nmub)              :: s1     !  Description and declaration in esm_alloc_real.f90
    integer     , dimension(gdp%d%nmlb:gdp%d%nmub), intent(in)  :: kcs    !  Description and declaration in esm_alloc_int.f90
    integer     , dimension(gdp%d%nmlb:gdp%d%nmub), intent(in)  :: kfs    !  Description and declaration in esm_alloc_int.f90
!
! Local variables
!
    integer    :: nm
    logical    :: success
!
!! executable statements -------------------------------------------------------
!
    sdufirst  =>   gdp%gdsdu%sdufirst
    sdu_t0    =>   gdp%gdsdu%sdu_t0
    sdu_tp    =>   gdp%gdsdu%sdu_tp
    sdu_tn    =>   gdp%gdsdu%sdu_tn
    itdate    =>   gdp%gdexttim%itdate
    tzone     =>   gdp%gdexttim%tzone
    lfsdus1   =>   gdp%gdprocs%lfsdus1
    !
    if (.not. sdufirst) then
        ! set previous level (tp) before setting new value (tn)
        do nm = gdp%d%nmlb, gdp%d%nmub
           sdu_tp(nm) = sdu_tn(nm)
        enddo
    endif

    success = meteoupdate(gdp%runid, itdate, tzone, timhr*60.0_fp)
    success = getmeteoval(gdp%runid, 'sdu', timhr*60.0_fp, gdp%gdparall%mfg, gdp%gdparall%nfg, &
                           & gdp%d%nlb, gdp%d%nub, gdp%d%mlb, gdp%d%mub, sdu_tn , 0)
    call checkmeteoresult(success, gdp)
    if (sdufirst) then
        do nm = gdp%d%nmlb, gdp%d%nmub
            sdu_tp(nm) = sdu_tn(nm)
            sdu_t0(nm) = sdu_tn(nm)
        enddo
        sdufirst = .false.
    endif
    do nm = gdp%d%nmlb, gdp%d%nmub
       !
       !  Update dps point
       !
       if (kcs(nm) > 0) then
           dps(nm) = dps(nm) - sdu_tn(nm) + sdu_tp(nm)
           if (kfs(nm) == 0 .or. lfsdus1) then
               s1(nm)  = s1(nm)  + sdu_tn(nm) - sdu_tp(nm)
           endif
       endif
    enddo
    !
    !
end subroutine incsdu

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
module Mod_nsc_pr_HangingNodes
   use typre
   use Mod_nsc_pr_BaseElmope
   implicit none
   private
   public SetPointersHangingNodes,ModifyMatricesHanging

   integer(ip), allocatable :: kfl_IsSet
   integer(ip) :: kfl_HangingNodes = 0_ip

contains

   !----------------------------------------------------------------------------
   !Setting Pointers

   subroutine SetPointersHangingNodes(itask)
      implicit none
      integer(ip) :: itask
      select case (itask)

      case(0)
         allocate(kfl_IsSet)
         call a%Memor%allocObj(0,'kfl_IsSet','InitProcedurePointer',1)
         kfl_IsSet = -1

      case(1)
         if (kfl_IsSet == -1) then
            kfl_IsSet = 1

            !-------------------------------------------------------
            !Hanging Nodes
            call a%Mesh%GetHanging(kfl_HangingNodes)
            if (kfl_HangingNodes == 1) then

               call ConcatenateProcedures(ProcHook_nsc_pr_PreDirichlet,ModifyMatricesHanging)
            endif

         endif
      case(100)
         deallocate(kfl_IsSet)
         call a%Memor%deallocObj(0,'kfl_IsSet','InitProcedurePointer',1)

      end select
   end subroutine

   !For actual computations
   !------------------------------------------------------
   !Hanging nodes

   subroutine ModifyMatricesHanging
      implicit none

      call a%Mesh%PrepareHangingMatrices(e,elmat,elrhs)
   end subroutine

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
!-------------------------------------------------------------------------------
!  The @fixed_width, @begin_table, @item2 and @end_table commands are custom
!  defined commands in Doxygen.in. They are defined under ALIASES. For the page
!  created here, the 80 column limit is exceeded. Arguments of aliases are
!  separated by ','. If you intended ',' to be a string you must use an escaped
!  comma '\,'.
!
!>  @page sxrem_dot_sec Soft X-Ray Diagnostic Dot File
!>
!>  @tableofcontents
!>  @section sxrem_dot_intro_sec Introduction
!>  Diagnostic dot files specify geometric and auxiliary information about each
!>  diagnostic. Parsing of a diagnostic dot file begins by searching for a valid
!>  keyword. All lines before a valid keyword is reached are ignored allowing
!>  for comments and other information to be inserted in the file. Once a
!>  keyword is reached, the parsing becomes strict. The diagnostic description
!>  format is dependant on the specific keyword. All diagnostic dot files must
!>  end with an @fixed_width{end_of_file} keyword.
!>
!>  This document contains information about the soft x-ray chord
!>  specifications. Chords are specified in a structured text file. This file is
!>  read in by the @ref v3fit_input::sxrch_dot_filename variable of the name
!>  list input file. Chords are specified as two verticies in either meters or
!>  radians.
!>
!>  @section sxrem_dot_key_sec Keywords
!>  @begin_table
!>  @item2{@fixed_width{sxr_chord_XYZ},                 A soft x-ray chord specified in Cartesian coordinates.}
!>  @item2{@fixed_width{sxr_chord_RPhiDegZ},            A soft x-ray chord specified in Cylindrical coordinates.}
!>  @item2{@fixed_width{sxr_chord_XYZ_geo},             A soft x-ray chord specified in Cartesian coordinates with the geometric factor.}
!>  @item2{@fixed_width{sxr_chord_RPhiDegZ_geo},        A soft x-ray chord specified in Cylindrical coordinates with the geometric factor.}
!>  @item2{@fixed_width{sxr_chord_XYZ_xics_emiss},      A XICS emission chord specified in Cartesian coordinates.}
!>  @item2{@fixed_width{sxr_chord_RPhiDegZ_xics_emiss}, A XICS emission chord specified in Cylindrical coordinates.}
!>  @item2{@fixed_width{sxr_chord_XYZ_xics_ti},         A XICS electron temperature chord specified in Cartesian coordinates.}
!>  @item2{@fixed_width{sxr_chord_RPhiDegZ_xics_ti},    A XICS electron temperature chord specified in Cylindrical coordinates.}
!>  @item2{@fixed_width{sxr_new_profile},        Mark the start of chords that begin the next profile.}
!>  @end_table
!>
!>  @section sxrem_dot_chord_spec_sec Chord Specification
!>  All soft x-ray chords are specified in the following manner.
!>
!>  @fixed_width{key_word\n}
!>  @fixed_width{name(STRING len:@ref data_parameters::data_short_name_length)\n}
!>  @fixed_width{x1(REAL) y1(REAL) z1(REAL)\n}
!>  @fixed_width{x2(REAL) y2(REAL) z2(REAL)\n}
!>
!>  Keywords that end with _geo, contain an extra geomtric factor.
!>
!>  @fixed_width{key_word_geo\n}
!>  @fixed_width{name(STRING len:@ref data_parameters::data_short_name_length)\n}
!>  @fixed_width{x1(REAL) y1(REAL) z1(REAL)\n}
!>  @fixed_width{x2(REAL) y2(REAL) z2(REAL)\n}
!>  @fixed_width{geo(REAL)\n}
!>
!>  @section sxrem_dot_exam_sec Example File
!>  @code
!>  !  A soft x-ray chord specified in Cartesian coordinates.
!>  sxr_chord_XYZ
!>  sxr001
!>  1.0 0.0 0.0
!>  0.5 0.0 0.0
!>
!>  !  A soft x-ray chord specified in Cylindrical coordinates.
!>  sxr_chord_RPhiDegZ
!>  sxr002
!>  1.0 0.0 0.0
!>  0.5 0.0 0.0
!>
!>  !  All files must end with
!>  end_of_file
!>  @endcode
!>
!>  @subsection sxrem_dot_exam_two_color_sec Two Color Example File
!>  @code
!>  !  A soft x-ray chord specified in Cartesian coordinates.
!>  sxr_chord_XYZ
!>  sxr001
!>  1.0 0.0 0.0
!>  0.5 0.0 0.0
!>
!>  sxr_new_profile
!>
!>  !  A soft x-ray chord specified in Cylindrical coordinates.
!>  sxr_chord_RPhiDegZ
!>  sxr002
!>  1.0 0.0 0.0
!>  0.5 0.0 0.0
!>
!>  !  All files must end with
!>  end_of_file
!>  @endcode
!>
!>  @section sxrem_dot_prog_ref_sec Programmers Reference
!>  Reference material for the coding to parse these files can be found in the
!>  @ref signal_dot and @ref sxrch_dot modules.
!-------------------------------------------------------------------------------
!*******************************************************************************
!>  @file sxrch_dot.f
!>  @brief Contains module @ref sxrch_dot
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  Module for opening and reading a 'sxrch.' file. The file format for these
!>  files are documented in @ref sxrem_dot_sec.
!*******************************************************************************

      MODULE sxrch_dot

      USE stel_kinds
      USE stel_constants
      USE signal_dot

      IMPLICIT NONE

      CONTAINS
!*******************************************************************************
!  UTILITY SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Read a soft x-ray diagnostic dot file.
!>
!>  Parses the structure of a dignostic dot file and constructs a @ref sxrem
!>  object. Each chord is parsed by @ref sxrch_dot_parse_chord.
!>
!>  @param[in]    sxrch_file      Name of the sxrch. file.
!>  @param[inout] signals         Array of pointers to the a signal
!>  @param[inout] signals_created Number valid signals in the array, or index of
!>                                the last signal created.
!>  @param[in]    observed        Array of observed values.
!>  @param[in]    sigma           Array of observed sigma values
!>  @param[in]    weight          Array of signal weight values
!>  @param[inout] first_index     Index of the first instance of an intpol
!>                                signal.
!>  @todo FIXME: Remove the _new when removing the old code.
!-------------------------------------------------------------------------------
      SUBROUTINE sxrch_dot_read(sxrch_file, signals, signals_created,          &
     &                          observed, sigma, weight, first_index)
      USE signal
      USE data_parameters

      IMPLICIT NONE

!  Declare Arguments
      CHARACTER (len=path_length), INTENT(in)            :: sxrch_file
      TYPE (signal_pointer), DIMENSION(:), INTENT(inout) :: signals
      INTEGER, INTENT(inout) :: signals_created
      REAL (rprec), DIMENSION(:), INTENT(in)             :: observed
      REAL (rprec), DIMENSION(:), INTENT(in)             :: sigma
      REAL (rprec), DIMENSION(:), INTENT(in)             :: weight
      INTEGER, INTENT(inout)                             :: first_index

!  local parameters
!  n_sxrchd_keyword        integer - number of sxrchd_keyword s.
      INTEGER, PARAMETER :: n_sxrchd_keyword = 10

!  local variables
!  sxrchd_keyword    character array - keywords for various sxrch input types
      CHARACTER(len=data_name_length), DIMENSION(1:n_sxrchd_keyword) ::        &
     &   sxrchd_keyword
      TYPE(signal_dot_file)                 :: sxrch_dot_file_ref
      INTEGER                               :: current_profile
      REAL (rprec)                          :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

!  Initialize the keywords
      sxrchd_keyword(1) = 'sxr_chord_XYZ'
      sxrchd_keyword(2) = 'sxr_chord_RPhiDegZ'
      sxrchd_keyword(3) = 'sxr_chord_XYZ_geo'
      sxrchd_keyword(4) = 'sxr_chord_RPhiDegZ_geo'
      sxrchd_keyword(5) = 'sxr_chord_XYZ_xics_emiss'
      sxrchd_keyword(6) = 'sxr_chord_RPhiDegZ_xics_emiss'
      sxrchd_keyword(7) = 'sxr_chord_XYZ_xics_ti'
      sxrchd_keyword(8) = 'sxr_chord_RPhiDegZ_xics_ti'
      sxrchd_keyword(9) = 'sxr_new_profile'
      sxrchd_keyword(10) = 'end_of_file'

!  Open up the 'sxrch.' file
      sxrch_dot_file_ref = signal_dot_open(TRIM(sxrch_file), 'sxrch')

!  Start with the first profile
      current_profile = 1

!  Infinite Loop
!  Character variable line should be defined on entry
      DO
!  Branch on the keyword
         SELECT CASE (signal_dot_read_keyword(sxrch_dot_file_ref,              &
     &                                        sxrchd_keyword))

            CASE DEFAULT ! This case should never fire.
               EXIT ! Exit out of infinte loop.

            CASE ('end_of_file')
               EXIT ! Exit out of infinte loop.

            CASE ('sxr_chord_XYZ', 'sxr_chord_XYZ_xics_emiss')
               CALL sxrch_dot_parse_chord(sxrch_dot_file_ref,                  &
     &                                    'XYZ', signals,                      &
     &                                    signals_created,                     &
     &                                    observed, sigma, weight,             &
     &                                    current_profile, first_index,        &
     &                                    .false., .false.)

            CASE ('sxr_chord_RPhiDegZ', 'sxr_chord_RPhiDegZ_xics_emiss')
               CALL sxrch_dot_parse_chord(sxrch_dot_file_ref,                  &
     &                                    'RPHiDegZ', signals,                 &
     &                                    signals_created,                     &
     &                                    observed, sigma, weight,             &
     &                                    current_profile, first_index,        &
     &                                    .false., .false.)

            CASE ('sxr_chord_XYZ_geo')
               CALL sxrch_dot_parse_chord(sxrch_dot_file_ref,                  &
     &                                    'XYZ', signals,                      &
     &                                    signals_created,                     &
     &                                    observed, sigma, weight,             &
     &                                    current_profile, first_index,        &
     &                                    .true., .false.)

            CASE ('sxr_chord_RPhiDegZ_geo')
               CALL sxrch_dot_parse_chord(sxrch_dot_file_ref,                  &
     &                                    'RPHiDegZ', signals,                 &
     &                                    signals_created,                     &
     &                                    observed, sigma, weight,             &
     &                                    current_profile, first_index,        &
     &                                    .true., .false.)

            CASE ('sxr_chord_XYZ_xics_ti')
               CALL sxrch_dot_parse_chord(sxrch_dot_file_ref,                  &
     &                                    'XYZ', signals,                      &
     &                                    signals_created,                     &
     &                                    observed, sigma, weight,             &
     &                                    current_profile, first_index,        &
     &                                    .false., .true.)

            CASE ('sxr_chord_RPhiDegZ_xics_ti')
               CALL sxrch_dot_parse_chord(sxrch_dot_file_ref,                  &
     &                                    'RPHiDegZ', signals,                 &
     &                                    signals_created,                     &
     &                                    observed, sigma, weight,             &
     &                                    current_profile, first_index,        &
     &                                    .false., .true.)

            CASE ('sxr_new_profile')
               current_profile = current_profile + 1

         END SELECT

      END DO

!  Close the 'sxrch.' file
      CALL signal_dot_close(sxrch_dot_file_ref)

      CALL profiler_set_stop_time('sxrch_dot_read', start_time)

      END SUBROUTINE

!*******************************************************************************
!  PARSING SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Parse soft x-ray diagnostic chord.
!>
!>  Parses a single chord. Chords are laid out as,
!>
!>  * chord_name
!>  * Starting point as three reals.
!>  * Ending point as three reals.
!>
!>  @param[in]    sxrch_dot_file_ref Reference to the sxrch. file.
!>  @param[in]    coordinate_type    Specifies the cartesian or cylindrical
!>                                   coordinate type.
!>  @param[inout] signals            Array of pointers to the a signal
!>  @param[inout] signals_created    Number valid signals in the array, or index
!>                                   of the last signal created.
!>  @param[in]    observed           Array of observed values.
!>  @param[in]    sigma              Array of observed sigma values
!>  @param[in]    weight             Array of signal weight values
!>  @param[in]    current_profile    Index of sxrem profile used.
!>  @param[inout] first_index        Index of the first instance of an intpol
!>                                   signal.
!>  @param[in]    use_geo            Chord contains geomtric factor.
!>  @param[in]    is_ti              Chord used electron temperature.
!-------------------------------------------------------------------------------
      SUBROUTINE sxrch_dot_parse_chord(sxrch_dot_file_ref,                     &
     &                                 coordinate_type,                        &
     &                                 signals,                                &
     &                                 signals_created,                        &
     &                                 observed, sigma, weight,                &
     &                                 current_profile, first_index,           &
     &                                 use_geo, is_ti)
      USE sxrem
      USE v3fit_input, only: v3fit_max_diagnostics,                            &
     &                       v3fit_input_find_scale_index,                     &
     &                       v3fit_input_find_offset_index
      USE v3_utilities, only: err_fatal

      IMPLICIT NONE

!  Declare Arguments
      TYPE (signal_dot_file), INTENT(inout)  :: sxrch_dot_file_ref
      CHARACTER (len=*), INTENT(in)          :: coordinate_type
      TYPE (signal_pointer), DIMENSION(:), INTENT(inout) :: signals
      INTEGER, INTENT(inout)                 :: signals_created
      REAL (rprec), DIMENSION(:), INTENT(in) :: observed
      REAL (rprec), DIMENSION(:), INTENT(in) :: sigma
      REAL (rprec), DIMENSION(:), INTENT(in) :: weight
      INTEGER, INTENT(in)                    :: current_profile
      INTEGER, INTENT(inout)                 :: first_index
      LOGICAL, INTENT(in)                    :: use_geo
      LOGICAL, INTENT(in)                    :: is_ti

!  local variables
      REAL(rprec), DIMENSION(3)              :: xcart_i, xcart_f
      CHARACTER (len=data_short_name_length) :: chord_name
      REAL (rprec)                           :: geo
      CLASS (sxrem_class), POINTER           :: sxrem_obj
      REAL (rprec)                           :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

!  Check if there are two many signals.
      IF (signals_created + 1 .gt. v3fit_max_diagnostics) THEN
         CALL err_fatal('sxrch_dot_parse_chord_new: created signals' //        &
     &                  ' exceeds v3fit_max_diagnostics')
      END IF

!  Get the start, end and name of chord.
      CALL signal_dot_parse_chord(sxrch_dot_file_ref,                          &
     &                            coordinate_type,                             &
     &                            chord_name,                                  &
     &                            xcart_i, xcart_f)

!  Default the geometric factor to 1.
      geo = 1.0
      IF (use_geo) THEN
         geo = signal_dot_parse_real(sxrch_dot_file_ref,                       &
     &            'Expected geometric factor for sxrem chord')
      END IF

      IF (is_ti) THEN
         sxrem_obj => sxrem_ti_class(xcart_i, xcart_f, current_profile)
         CALL signal_construct(sxrem_obj, chord_name, chord_name, 'eVm',       &
     &           observed(signals_created + 1),                                &
     &           sigma(signals_created + 1),                                   &
     &           weight(signals_created + 1),                                  &
     &           v3fit_input_find_scale_index(signals_created + 1),            &
     &           v3fit_input_find_offset_index(signals_created + 1))
      ELSE
         sxrem_obj => sxrem_emiss_class(xcart_i, xcart_f, geo,                 &
     &                                  current_profile)
         CALL signal_construct(sxrem_obj, chord_name, chord_name, 'arb',       &
     &           observed(signals_created + 1),                                &
     &           sigma(signals_created + 1),                                   &
     &           weight(signals_created + 1),                                  &
     &           v3fit_input_find_scale_index(signals_created + 1),            &
     &           v3fit_input_find_offset_index(signals_created + 1))
      END IF

      signals(signals_created + 1)%p => sxrem_obj

      signals_created = signals_created + 1

!  At lease one sxrem signal was made. Set the first index. This should only be
!  run once.
      IF (first_index .eq. -1) THEN
         first_index = signals_created
      END IF

      CALL profiler_set_stop_time('sxrch_dot_parse_chord', start_time)

      END SUBROUTINE

      END MODULE


text:
PROGRAM test_getarg
  INTEGER :: i
  CHARACTER(len=32) :: arg

  DO i = 1, iargc()
    CALL getarg(i, arg)
    WRITE (*,*) arg
  END DO
END PROGRAM

max_stars_repo_name: AtilaSaraiva/scratch

max_issues_repo_name: AtilaSaraiva/scratch

max_forks_repo_name: AtilaSaraiva/scratch


text:
 subroutine create_boundary_simple( dist )

   type :: distrb
    ! integer proc(7)
      integer , dimension(:), pointer :: &
         proc              ,&! processor location for this block
         local_block         ! block position in local array on proc
   end type

! !INPUT PARAMETERS:
   type (distrb), intent(in) :: dist  ! distribution of blocks across procs

   integer :: nblocks

   nblocks = size(dist%proc(:))

 ! lalloc_tripole = .false.
 ! newbndy%communicator = dist%communicator

end subroutine

module distribution

   implicit none
   private
   save

! !PUBLIC TYPES:

   type, public :: distrb  ! distribution data type
      integer :: &
         nprocs            ,&! number of processors in this dist
         communicator        ! communicator to use in this dist

      integer , dimension(:), pointer :: &
         proc              ,&! processor location for this block
         local_block         ! block position in local array on proc
   end type

contains

subroutine create_boundary(newbndy, dist, &
                            ns_bndy_type, ew_bndy_type, &
                            nx_global, ny_global)

! !DESCRIPTION:
!  This routine creates a boundary type with info necessary for
!  performing a boundary (ghost cell) update based on the input block
!  distribution.
!
! !REVISION HISTORY:
!  same as module

! !INPUT PARAMETERS:

   integer  newbndy

   type (distrb), intent(in) :: &
      dist       ! distribution of blocks across procs

   character (*), intent(in) :: &
      ns_bndy_type,             &! type of boundary to use in ns dir
      ew_bndy_type               ! type of boundary to use in ew dir

   integer, intent(in) :: &
      nx_global, ny_global       ! global extents of domain

! !OUTPUT PARAMETERS:

!EOP
!BOC
!-----------------------------------------------------------------------
!
!  local variables
!
!-----------------------------------------------------------------------

   integer ::           &
      i,j,k,n,                     &! dummy counters
      iblock_src  , jblock_src  ,  &! i,j index of source block
      iblock_dst  , jblock_dst  ,  &! i,j index of dest   block
      iblock_north, jblock_north,  &! i,j index of north neighbor block
      iblock_south, jblock_south,  &! i,j index of south neighbor block
      iblock_east , jblock_east ,  &! i,j index of east  neighbor block
      iblock_west , jblock_west ,  &! i,j index of west  neighbor block
      src_block_loc,               &! local block location of source
      dst_block_loc,               &! local block location of dest
      imsg_ew_snd, imsg_ew_rcv,    &! counters for ew send/recv
      imsg_ns_snd, imsg_ns_rcv,    &! counters for ns send/recv
      nprocs,                      &! num of processors involved
      nblocks,                     &! total number of blocks
      bid, pid,                    &! block and processor locators
      iblk, imsg,                  &!
      iloc_ew, iloc_ns,            &!
      src_proc, dst_proc            ! src,dst processor for message

   logical :: &
      lalloc_tripole      ! flag for allocating tripole buffers

   integer, dimension(:), allocatable :: &
      ew_snd_count,    &! array for counting blocks in each message
      ew_rcv_count,    &! array for counting blocks in each message
      ns_snd_count,    &! array for counting blocks in each message
      ns_rcv_count,    &! array for counting blocks in each message
      msg_ew_snd  ,    &! msg counter for each active processor
      msg_ew_rcv  ,    &! msg counter for each active processor
      msg_ns_snd  ,    &! msg counter for each active processor
      msg_ns_rcv        ! msg counter for each active processor

!-----------------------------------------------------------------------
!
!  Initialize some useful variables and return if this task not
!  in the current distribution.
!
!-----------------------------------------------------------------------

   nprocs = dist%nprocs

!   if (my_task >= nprocs) return

   nblocks = size(dist%proc(:))
   lalloc_tripole = .false.
!   newbndy%communicator = dist%communicator

end subroutine

end module

end

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


    program demo_co_min
    implicit none
    integer :: val
       val = this_image()
       call co_min(val, result_image=1)
       if (this_image() == 1) then
         write(*,*) "Minimal value", val  ! prints 1
       endif
    end program demo_co_min


text:
!  **********************************************************************
!  *                                                                    *
!  *                   Integer Function iseed                           *
!  *                                                                    *
!  **********************************************************************
!  Single Precision Version 1.1
!  Written by Gordon A. Fenton, Princeton, Dec. 8, 1988.
!  Latest Update: Oct 14, 1996
!
!  PURPOSE  initializes the system pseudo-random number generated using
!           process ID as default seed.
!
!  Initializes the local random number generator RANDF. If the argument integer
!  seed (kseed) is zero, a random seed is calculated based on the process ID
!  of the parent process. The function returns the actual seed used. This
!  routine is system specific.
!
!  Notes:
!   1) any function which is reasonably certain to return a different integer
!      on each invocation of the calling process can be used to generate a
!      pseudo-random seed here. Some possibilities might be wall clock time,
!      Process ID number (UNIX based)...
!
!  Requires:
!   1) from Fortran lib: GETPID
!
!  REVISION HISTORY:
!  1.1	now using new randu function (RAN2 from Numerical Recipes, 2nd Ed)
!	(Oct 14/96)
!--------------------------------------------------------------------------
      integer function iseed2( kseed )
      integer kseed, getpid
!
      iseed2 = kseed
      if( kseed .eq. 0 ) then
!                                avoid seeds of 0
	  iseed2 = getpid() + 2
      endif
!                                initialize the generator
      rfirst2 = randu2( iseed2 )
      return
      end

max_stars_repo_name: leemargetts/PoreFEM

max_issues_repo_name: leemargetts/PoreFEM

max_forks_repo_name: leemargetts/PoreFEM


text:
MUGA Phone #1 on the Campus Payphones node

Phone Number: (530) 7531307

Location: Located in the MUGA, right before the stairs.  Can be seen from the main part of the Memorial Union.

Description: Sits in a wood case.

Charge: 50cent for local.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      program ifthenelse03

C     Bug: do not core dump for user errors such as a double ELSE

      read *,i

      if(i.eq.0) then
         print *, i
      else
         print *, i+1
      else
         print *,i-1
      endif

      end


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

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

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

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

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

! End MIT license text.

      SUBROUTINE WRITE_MATRIX_BY_COLS ( MAT_DESCR, MATOUT, NROWS, NCOLS, OUT_UNT )

! Writes a matrix one column at a time in a format that has 10 terms across the page (repeated un til col is completely written)

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  WRITE_MATRIX_BY_COLS_BEGEND

      USE WRITE_VECTOR_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'WRITE_MATRIX_BY_COLS'
      CHARACTER(LEN=*), INTENT(IN)    :: MAT_DESCR          ! Character descriptor of the matrix to be printed
      CHARACTER(131*BYTE)             :: HEADER             ! MAT_DESCRIPTOR centered in a line of output

      INTEGER(LONG), INTENT(IN)       :: NROWS              ! Number of rows in matrix MATOUT
      INTEGER(LONG), INTENT(IN)       :: NCOLS              ! Number of cols in matrix MATOUT
      INTEGER(LONG), INTENT(IN)       :: OUT_UNT            ! Output unit number
      INTEGER(LONG)                   :: I,J,K              ! DO loop indices
      INTEGER(LONG)                   :: NUM_LEFT           !
      INTEGER(LONG)                   :: PAD                ! Number of spaces to pad in HEADER to center MAT_DESCRIPTOR
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = WRITE_MATRIX_BY_COLS_BEGEND

      REAL(DOUBLE) , INTENT(IN)       :: MATOUT(NROWS,NCOLS)! Matrix to write out
      REAL(DOUBLE)                    :: MAT_LINE(10)       ! Up to 10 terms from one col of MATOUT

      INTRINSIC                       :: LEN

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
      PAD = (132 - LEN(MAT_DESCR))/2
      HEADER(1:) = ' '
      HEADER(PAD+1:) = MAT_DESCR
      WRITE(OUT_UNT,101) HEADER

      DO J=1,NCOLS
         WRITE(OUT_UNT,102) J
         NUM_LEFT = NROWS
         DO I=1,NROWS,10
            IF (NUM_LEFT >= 10) THEN
               DO K=1,10
                  MAT_LINE(K) = MATOUT(I+K-1,J)
               ENDDO
               WRITE(OUT_UNT,103) (MAT_LINE(K),K=1,10)
            ELSE
               DO K=1,NUM_LEFT
                  MAT_LINE(K) = MATOUT(I+K-1,J)
               ENDDO
               WRITE(OUT_UNT,103) (MAT_LINE(K),K=1,NUM_LEFT)
            ENDIF
            NUM_LEFT = NUM_LEFT - 10
         ENDDO
         WRITE(OUT_UNT,*)
      ENDDO

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  101 FORMAT(1X,/,1X,131A,/)

  102 FORMAT(1X,'COLUMN ',I8,/,1X,'---------------')

  103 FORMAT(1X,10(1ES14.6))

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

      END SUBROUTINE WRITE_MATRIX_BY_COLS


text:
      SUBROUTINE DLAORD( JOB, N, X, INCX )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            INCX, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
*     ..
*
*  Purpose
*  =======
*
*  DLAORD sorts the elements of a vector x in increasing or decreasing
*  order.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER
*          = 'I':  Sort in increasing order
*          = 'D':  Sort in decreasing order
*
*  N       (input) INTEGER
*          The length of the vector X.
*
*  X       (input/output) DOUBLE PRECISION array, dimension
*                         (1+(N-1)*INCX)
*          On entry, the vector of length n to be sorted.
*          On exit, the vector x is sorted in the prescribed order.
*
*  INCX    (input) INTEGER
*          The spacing between successive elements of X.  INCX >= 0.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, INC, IX, IXNEXT
      DOUBLE PRECISION   TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      INC = ABS( INCX )
      IF( LSAME( JOB, 'I' ) ) THEN
*
*        Sort in increasing order
*
         DO 20 I = 2, N
            IX = 1 + ( I-1 )*INC
   10       CONTINUE
            IF( IX.EQ.1 )
     $         GO TO 20
            IXNEXT = IX - INC
            IF( X( IX ).GT.X( IXNEXT ) ) THEN
               GO TO 20
            ELSE
               TEMP = X( IX )
               X( IX ) = X( IXNEXT )
               X( IXNEXT ) = TEMP
            END IF
            IX = IXNEXT
            GO TO 10
   20    CONTINUE
*
      ELSE IF( LSAME( JOB, 'D' ) ) THEN
*
*        Sort in decreasing order
*
         DO 40 I = 2, N
            IX = 1 + ( I-1 )*INC
   30       CONTINUE
            IF( IX.EQ.1 )
     $         GO TO 40
            IXNEXT = IX - INC
            IF( X( IX ).LT.X( IXNEXT ) ) THEN
               GO TO 40
            ELSE
               TEMP = X( IX )
               X( IX ) = X( IXNEXT )
               X( IXNEXT ) = TEMP
            END IF
            IX = IXNEXT
            GO TO 30
   40    CONTINUE
      END IF
      RETURN
*
*     End of DLAORD
*
      END

max_stars_repo_name: haampie/libflame

max_issues_repo_name: haampie/libflame

max_forks_repo_name: haampie/libflame


text:
*
* $Id$
*
      implicit none
      integer maxn
      parameter (maxn = 100000)
      double precision a(maxn), b(maxn), c(maxn), s
c
      integer i, j, n, nloop, loop
      double precision linux_cputime, start, usedf, usedb, ratef, rateb
      external linux_cputime
c
      do i = 1, n
         a(i) = 2.0d0
         b(i) = 1.0d0
         c(i) = 3.0d0
      enddo
c
      n = 1
      s = 4.5d0
c
 10   nloop = 10000000/n + 1
      start = linux_cputime()
      do loop = 1, nloop
         do i = 1, n
            a(i) = a(i) + s*b(i)
         enddo
      enddo
      usedf = linux_cputime() - start
      ratef = 1d-6 * n * nloop / usedf
      start = linux_cputime()
      do loop = 1, nloop
         call daxpy(n, s, b, 1, a, 1)
      enddo
      usedb = linux_cputime() - start
      rateb = 1d-6 * n * nloop / usedb
      write(6,1) n, usedf, ratef, usedb, rateb
 1    format(1x,i8,2f10.3,2x,2f10.3)
      n = n * 2
      if (n .lt. maxn) goto 10
c
      end

max_stars_repo_name: dinisAbranches/nwchem

max_issues_repo_name: dinisAbranches/nwchem

max_forks_repo_name: dinisAbranches/nwchem


text:
      SUBROUTINE FRSW2 (V1,V2,V3,VB)
C
C     LAST REVISED  11/91, BY G.CHAN/UNISYS
C     ADDITION OF A NEW FORWARD-BACKWARD SUBSTITUTION METHOD, WHICH IS
C     MORE EFFICIENT, AND IS ALREADY GOOD FOR VECTORIZATION.
C
CDB   LOGICAL          DEBUG
      INTEGER          NAM(6)  ,LJJ(2) ,IBLK(15),BASE
      DOUBLE PRECISION V1(1)   ,V2(1)  ,V3(1)   ,VB(1) ,XL(1) ,XLJJ  ,
     1                 V3J     ,ZERO   ,SUM
      COMMON  /OPINV / MCBLT(7),MCBSMA(7)
      COMMON  /SYSTEM/ KSYSTM  ,IO
      COMMON  /FEERXX/ DUMM(18),NZVB
      COMMON  /ZZZZZZ/ IZ(1)
      EQUIVALENCE      (XL(1),IZ(1))
      EQUIVALENCE      (LJJ(1) ,XLJJ)  ,(L16,DUMM(6))
      DATA     NAM   / 4HFRSW  ,4H2    ,2*4HBEGN,4HEND ,4HBGIN /
      DATA     ZERO  / 0.0D+0        /
CDB   DATA     DEBUG , ITER    ,MAX  / .FALSE.  ,0     ,3      /
C
CDB   IF (.NOT.DEBUG) GO TO 20
C     ITER = ITER + 1
C     IF (ITER .GT. MAX) DEBUG = .FALSE.
C     WRITE  (IO,10) NZVB,ITER
C  10 FORMAT ('  .... IN FRSW2.  NZVB =',I8,',   ITER =',I3)
C  20 CONTINUE
      NROW = MCBLT(2)
      CALL FRMLTD (MCBSMA(1),V1(1),V3(1),VB(1))
      IF (MCBLT(7) .LT. 0) GO TO 200
C
C     NASTRAN ORIGINAL METHOD
C
      IBLK( 1) = MCBLT(1)
      IBLK( 9) = 1
      IBLK(10) = 1
      CALL REWIND (MCBLT)
      CALL SKPREC (MCBLT,1)
C
C     FORWARD SWEEP DIRECTLY ON V3
C
      DO 80 J = 1,NROW
      IBLK(8) = -1
   30 CALL GETSTR (*70,IBLK(1))
      JI   = IBLK(5)
      NTMS = IBLK(6)
      IK   = IBLK(4)
      IF (IK .NE. J) GO TO 40
      NTMS = NTMS - 1
      XLJJ = XL(JI)
      JI   = JI + 1
      IK   = IK + 1
   40 IF (NTMS .EQ. 0) GO TO 60
      V3J  = V3(J)
      IF (V3J .EQ. ZERO) GO TO 60
      DO 50 II = 1,NTMS
      V3(IK) = V3(IK) + XL(JI)*V3J
      IK   = IK + 1
      JI   = JI + 1
   50 CONTINUE
   60 CALL ENDGET (IBLK(1))
      GO TO 30
   70 V3(J)= V3(J)/XLJJ
   80 CONTINUE
C
C     BACKWARD SUBSTITUTION OMIT DIAGONAL
C
      IF (NROW .EQ. 1) GO TO 500
      J    = NROW
   90 IBLK(8) = -1
  100 CALL GETSTB (*130,IBLK(1))
      NTMS = IBLK(6)
      JI   = IBLK(5)
      IK   = IBLK(4)
      IF (IK-NTMS+1 .EQ. J) NTMS = NTMS - 1
      IF (NTMS .EQ. 0) GO TO 120
      SUM  = ZERO
      DO 110 II = 1,NTMS
      SUM  = SUM + XL(JI)*V3(IK)
      JI   = JI - 1
      IK   = IK - 1
  110 CONTINUE
      V3(J)= V3(J) + SUM
  120 CALL ENDGTB (IBLK(1))
      GO TO 100
  130 IF (J .EQ. 1) GO TO 500
      J    = J - 1
      GO TO 90
C
C     NEW METHOD
C
C     THE MCBLT MATRIX HAS BEEN RE-WRITTEN FORWARD FIRST THAN BACKWARD
C     BY UNPSCR IN FEER3. NO STRING OPERATION HERE
C
  200 IF (NAM(3) .EQ. NAM(5)) NAM(3) = NAM(6)
      IF (L16 .NE. 0) CALL CONMSG (NAM,3,0)
      MCBLTX =-MCBLT(7)
      IF (MOD(MCBLT(4),10) .NE. 2) GO TO 440
      NREC = 0
      CALL REWIND (MCBLTX)
      CALL FWDREC (*400,MCBLTX)
      NWDS = MCBLT(5)
C
C     IZ(1)                                                     GINO
C      / V1   V2    V3          VB (OPEN CORE LENGTH = NZVB)   BUFFERS
C     +-----+-----+-----+-----+-------------------------------+--------
C                         OPEN  CORE
C
C     FORWARD SWEEP DIRECTLY ON V3
C
      LL2  = 0
      BASE = 1
      IFB  = +450
      DO 270 J = 1,NROW
      IF (BASE .LT. LL2) GO TO 240
      NREC = NREC + 1
CDB   IF (DEBUG) WRITE (IO,210) NREC,IFB
C 210 FORMAT ('  ...READING RECORD',I5,'.   IFB =',I5)
      CALL READ (*400,*220,MCBLTX,VB,NZVB,1,LL)
      CALL MESAGE (-8,0,NAM)
  220 LL2  = LL/NWDS
CDB   LL3  = LL2/30
C     LL4  = LL2 - LL3
C     IF (DEBUG) WRITE (IO,230) LL,NREC,LL2
C 230 FORMAT (5X,I10,' WORDS READ FROM RECORD',I5,'.   LL2 =',I8)
      BASE = 1
  240 XLJJ = VB(BASE)
      II   = LJJ(1)
      JJ   = LJJ(2)
CDB   IF (DEBUG .AND. (BASE.LT.LL3 .OR. BASE.GT.LL4))
C    1    WRITE (IO,250) J,BASE,II,JJ,IFB
C 250 FORMAT (11X,'J,BASE,II,JJ,IFB =',5I8)
      IF (II .NE. J) GO TO 420
      NTMS = JJ - II + 1
      IB   = BASE + 2
      IE   = BASE + NTMS
      BASE = IE + 1
      IF (NTMS .LE. 1) GO TO 270
      V3J  = V3(J)
      IF (V3J .EQ. ZERO) GO TO 270
      DO 260 I = IB,IE
      II   = II + 1
  260 V3(II) = V3(II) + VB(I)*V3J
  270 V3(J)= V3(J)/VB(IB-1)
C
C     BACKWARD SUBSTITUTION OMIT DIAGONAL
C
      IF (NROW .EQ. 1) GO TO 500
      NREC = 0
      LL2  = 0
      BASE = 1
      J    = NROW
      IFB  = -490
      DO 310 JX = 1,NROW
      IF (BASE .LT. LL2) GO TO 290
      NREC = NREC + 1
CDB   IF (DEBUG) WRITE (IO,210) NREC,IFB
      CALL READ (*400,*280,MCBLTX,VB,NZVB,1,LL)
      CALL MESAGE (-8,0,NAM)
  280 LL2  = LL/NWDS
CDB   LL3  = LL2/30
C     LL4  = LL2 - LL3
C     IF (DEBUG) WRITE (IO,230) LL,NREC,LL2
      BASE = 1
  290 XLJJ = VB(BASE)
      II   = LJJ(1)
      JJ   = LJJ(2)
CDB   IF (DEBUG .AND. (BASE.LT.LL3 .OR. BASE.GT.LL4))
C    1    WRITE (IO,250) J,BASE,II,JJ,IFB
      IF (II .NE. J) GO TO 420
      NTMS = JJ - II + 1
      IB   = BASE + 2
      IE   = BASE + NTMS
      BASE = IE + 1
      IF (NTMS .LE. 1) GO TO 310
      SUM  = ZERO
      DO 300 I = IB,IE
      II   = II + 1
  300 SUM  = SUM + VB(I)*V3(II)
      V3(J)= V3(J) + SUM
  310 J    = J - 1
      GO TO 500
C
C     ERROR
C
  400 I = MCBLT(4)/10
      WRITE  (IO,410) NREC,J,I,IFB
  410 FORMAT ('0*** TRY TO READ RECORD',I5,'.  J,MCBLT(4),IFB =',I7,2I5)
      CALL MESAGE (-2,MCBLTX,NAM)
  420 WRITE  (IO,430) IFB,II,J
  430 FORMAT ('0*** ERROR.   IFB),II,J =',I5,1H),2I8)
      GO TO 460
  440 J = MOD(MCBLT(4),10)
      WRITE  (IO,450) J
  450 FORMAT ('0*** MCBLT MATRIX IN WRONG FORM.  UNPSCR FLAG =',I3)
  460 CALL MESAGE (-37,0,NAM)
C
  500 NAM(3) = NAM(5)
      IF (L16 .NE. 0) CALL CONMSG (NAM,3,0)
      RETURN
      END


text:
Shuz was a Shoe Stores & Repair shoe store located in downtown Davis, specializing in European comfort and walking shoes such as Sanita (the maker of Dansko for over 15 years), Beautifeel, 1803, Joseph Seibel (for men), Mephisto, Reiker, Ahnu, Pikolino, Think/Finn Comfort, Gabor, Birkenstock, and others, as well as socks, handbags, & shoe accessories. The business had been in Davis for over 30 years.

As the townies Davisites will tell you, Shuz used to just be Birkenstocks and kids Birkenstocks, before they expanded their selection greatly. Shuz was originally called Birkenstock Plus. It was originally located 129 E Street before moving to 710 2nd Street. Their expanded line of products prompted their renaming and move to their final, much larger location in the Chen Building.

This space was subsequently occupied by Sole Desire, selling similar brands of shoes, but for women only.

20050725 18:06:04 nbsp cant stand the name Users/BrianDarnell

20050726 12:31:34 nbsp Too expensive.  Either that, or maybe Im just not cultured enough to wear shoes that cost $200. Users/LacyCollum

20050726 22:35:52 nbsp I cant stand the name either. I work in the same building and I always think it is funny seeing the sandals in the window that are advertised as waterproof. Users/NickSchmalenberger

20051124 10:14:31 nbsp They dont sell Doc Martens. Nobody in Davis sells Docs, except sometimes the SPCA Thrift Store.  Users/EmmaCoats

20060307 11:01:00 nbsp Good service.  High quality, comfortable, durable shoes.  Worth checking for closeout bargains. Users/DickWarg

20060504 20:06:55 nbsp Really helpful service, wish I could afford the shoes:)   Users/JenCam

20061001 22:32:55 nbsp Fo Shuzzle! Users/JohnMolina

20061008 15:34:23 nbsp Whats their pricing policy? Do they match their competitors? Can you negotiate? Users/LiRic

20061102 17:13:27 nbsp Prices are pretty much set, but they do offer ten to fifteen percent off coupons in the Green machine and newspaper ads. Also, they have sales about once a season. (I work there, could you tell?) Users/ClaireImpens

20061102 18:42:58 nbsp I bought some groovy shoes there last year.  I like them a lot.  Also, have spent a fortune on kids shuz... Users/RocksandDirt

20061102 18:42:58 nbsp How is the name pronounced? Does it rhyme with does (not the female deer),
or buzz or fuzz? Would somebody let us know. Because Shuz sure doesnt remind me of footwear.
How can you trust a store whose name you cant pronounce?
Users/BrianKenyon

20061111 12:04:21 nbsp Its pronounced like shooz. And to think, there are 6 other stores with the same name! Users/ClaireImpens

20061112 15:37:21 nbsp even though its prounced shoes I still say it phonetically in my head Users/StevenDaubert

20061128 17:45:41 nbsp Attentive, friendly service.  I think the shoes seem to be on the pricier end b/c they only really carry high quality shoes. Users/JeffEdwards

20061130 18:05:35 nbsp SAS (theres a store in Citrus Heights) also makes pricey and very comfortable shoes. Users/RalphFinch

20070729 13:43:15 nbsp Great service.  The prices are retail, but theres usually a 10% off coupon in the green machine.  I like to try shoes on and support local business.  For those who try the shoes on at the store then buy cheaper online, Ill point out that without business the store wont be around so you can try on those shoes.  Its worth paying for the service. Users/rachelss

20080127 15:44:08 nbsp THEY ARE GREAT! PRICES ARE BASED ON THE QUALITY OF SHOES.....AND THE SERVICE THAT YOU WILL RECIEVE WHEN YOU ARE SHOPPING THERE. TRUST ME ITS WORTH IT. YOU WOULD BUY 4 OR 5 PAIRS OF CHEAP SHOES FOR THE SAME PRICE AS YOU WOULD BUY ONE PAIR THAT WOULD LAST 5 YEARS OR MORE!!!!! Users/KWILSON

20080226 09:01:03 nbsp Does anyone have an updated web address for this place? This one doesnt work. Users/Red

20080306 00:10:05 nbsp The owners are debating whether or not to update the website or scrap it so as of now the best way to check out the shoes is to come on by...were nice dont be afraid....theres even a candy bowl (usually) :) Users/daniellotangello

20080315 17:43:20 nbsp Great service! I got a pair of shoes there that ended up being uncomfortable. I had bought that brand before, so I didnt really try them on in the store as much as I should have. I was worried about taking them back to Shuz because I had managed to lose the receipt, but they took them back with no hassle for the full price I paid and helped me find a more comfortable brand. Very nice. :) Users/HeatherBeck

20080604 20:41:31 nbsp Whats the deal with the website? Users/AllisonEriksen

20090620 17:43:41 nbsp I dont like the name and the prices are high. But the staff is really nice. Users/jsg718

20090620 21:56:14 nbsp Shuz is the name, but with what do it rhyme? Scuz? Drudges? Blues? Fuzzes? News? Im confused, Shuz loses; guess elsewhere I must for footwear shop, since by the name no telling what they sell. Users/BrianJKenyon

20100211 08:13:31 nbsp Unique quality products from countries other then China. WOW! The name is just fine and judging from past comments we are in the company of a bunch of people with no sense of humor.  This is a fine local business which has been in town for many years and saves trips to Walnut Creek and San Francisco. So you outlet shoppers can look down your noses at them but class will always tell Lucy you dont lack culture you lack money.  Users/RENEERAVIOL

23 February, 2010: I have a rare negative comment about the staff at this store. About half of them are competent, pleasant people, the other are looking down their noses at me or are apparently customercareless stoners. When my wife called today to ask if shed left her credit card there, she was treated to a surferdudes errr... response. Only after her directly telling him to go and check did he respond in anything like a customerfocused way.

One of the few things that keeps me shopping locally rather than on the internet is that I can get actual personal service. I dont shop at places where I have to tell the staff to do their jobs, so Shuz has gone down in my estimation, and they need to make certain that their staff are alert to customer needs.

20100322 15:52:58 nbsp warning do NOT ever order shoes from here.. your they will be here in 7 to 10 days turns into 3+ weeks and when you ask about them you get well the warehouse said they shipped, that is all I know...and another thing you have to ask them to call and find out where and when your shoes will be in..pathetic custom service.. so next time you need a new pair of birkenstocks I suggest ordering online and not from the Shuz of Davis.. I know I will not be back...

 Users/Michaelv

20100503 14:44:22 nbsp I really wanted to give them my business, but after going in three times and them not having anything in my size, I had to order online from someone else.  I asked if they could order for me, and they couldnt do it.  They also didnt offer to take my name and give me a call when something came in.  I found it really frustrating, especially since I wanted to purchase locally ... oh well. Users/SallyCP

20100605 11:40:22 nbsp I went in to try some Birkenstocks (never have before).  The young woman who served me (the only person on the floor when I arrived) was unimpressive: My few specific, factual questions about Birkenstocks were met with neglegently capricious answers  she feigned attentiveness by affirming every postulate I made, regardless of it being the contradiction of a previous postulate.  So I left rather unenlightened about a famously complicated sandal, and in search of another store to fulfill my buying prerequisites.  A contrast to the fairly rigorous and at least genuine service I received at Fleet Feet. Users/GregPThrasher

Starting on Friday June 11, 2010 Shuz of Davis is having a Graduation sale!  Men shoes by Keen and Merrell at $49.99 a pair, 2 pairs for $80. As well as women 1803 shoes at $69.99, 2 pairs for $100. Sizes are limited. Come take a look before they are all gone!!! The entire inside of the store is on sale! Up to 20% off with no limit!

20100807 00:42:50 nbsp I am flabbergasted about what I am about to type.

A heel spur spurred a stop into Shuz earlier today, as the waving sign, 1 for 49, 2 for 80 clearance sale gave me a sliver of hope for a quick, possibly affordable remedy for pain. Instead, I have a shiver of regret.

I can not believe the outrageous lie that was told to me to make a sale. I am a lover of flipflops and running around barefoot. Since hiking five miles in said flipflops, what started as an aggravated ankle, shifted into full on heel pain. Shuz carries those high dollar, high podiatrist friendly, some even trendy shoes. I found a pair of Merrell Rosarita flipflops that had support and comfort built in. I asked the young woman what the original price was and she told me 120 dollars. Not knowing the brand, I didnt think to disbelieve what she was telling me. I quickly tried to find another pair of shoes that I might like so I could feel good about getting the best savings out of the whole deal. I found a pair that were, eyh but okay, who cares right... 2 for 80 and I already have a great sale on the first pair.

Wrong. But I didnt find out until AFTER I left the store. The woman told me that the original price of the other pair of shoes was 70 dollars. Sure, nice, fine. She didnt repeat the original price of the Merrells, I offered a bit of plastic and a signature, declined a bag and went on my way. What comes next is almost laughable, if I didnt feel so stupid, and taken for a ride by Shuz, Davis.

My receipt (all sale items are sale is final) lists a pair of shoes (not my Merrells) with the original price 170, yes 170 dollars, marked down to 40 and the other 70 dollar shoe, marked down to 40. I may have been born ten minutes ago to think a pair of flip flops could have an original price of 120, but sure shooting, I am not going to brag that they cost 170! Not only that, I looked them up online and they run for sixty something dollars.

So. To sell me two pairs of shoes, the woman lies to me about the original price and has to come up with an even pricier shoe to ring up so that I am none the wiser and walk away thinking  I have had the ultimate downtown davis local shopping experience.

All I can say is.... I dont know what to say. I am very disappointed in Shuz of Davis... Users/Chrissye

20100923 17:36:33 nbsp This is literally one of the worst places to shop. I went in the other day looking for shoes and I found this floral sanita clogs I really Liked. I told the lady that was helping me I believe her name is Chelsea that I needed to be back because I had not brought enough money. She said she would hold them for me until the end of the day. When I cam back with my friend and asked for the shoes I had placed on hold, Chelsea came out and told me her manager had sold them. I was mortified. Users/DeBoRaH21

20101221 20:42:01 nbsp My wife and I try to shop locally whenever possible. Weve shopped at Shuz for years and weve always been happy with their service and selection. But weve run into one sore spot  they have a 7 DAY RETURN POLICY! Thankfully, its possible to exchange for store credit that can be used later. Weve also learned to be careful when looking at sale items that often come with a NO RETURN policy.  Users/BHolmes

20110429 00:04:59 nbsp If youre a masochist, this is the place for you.

I took some birkenstocks to the Davis Shuz store to get refurbished.  I was told theyd be ready in 23 weeks .  But one of their employees abandoned them and so it took months before they were ready.  No big deal, I understand they cant help when someone leaves, and it was cold out anyway so I would not need them.  When I got around to picking them up, I was told they might dry out by the time it got warm out and I might need to apply more protectant to the cork.  So to prevent the drying, I put them in ziploc bags and set them under my bed.  A couple months later, it started getting warm out so I pulled them out and inspected them.  I had some concerns about the separation between the cork and the rubber bottom.  Also the straps did not tuck in as they had before.  I called to ask about whether it might be possible to get a store credit and just purchase a new pair through their store (for which I would voluntarily pay the $50 difference).  I was told to call the manager Jennifer at the Shuz of Rockridge store and she could tell me the deal.  So I called up and woah, here is where the sh% flew.

I’ve rarely talked to someone at a business who was so combative in her tone.  I asked for Jennifer, and she said which one, one doesn’t work here anymore.  I said the manager.  She said, well I’m the manager, and my name is JEN.  Oh, sorry, JEN, I was just using the name given by another employee and the name on the receipt I had from our earlier transaction.  When I went on to explain my situation, she continued to make it sound like the issues were my fault.  She said, you shouldn’t have put them in the bags.  How does that affect them?  I was just trying to keep them from drying out.  I didn’t leave them near a heat source or out in the sun and create some sort of greenhouse effect.  They were under my bed.  They don’t somehow generate their own heat that gets trapped in the bag.  The whole conversation continued like this on her side, combative…like she thought she was Florence on an episode of The Jeffersons trying to put George in his place.  After the abuse, she even had the audacity to suggest that they’d be happy to sell me a new pair of Birkenstocks at full price through their store.

No, thank you, I don’t like to pay for verbal abuse when I’m only asking about possible remedy or clarification about an issue.  Avoid.
 Users/RonB

20110529 13:55:39 nbsp The service given at Shuz of Davis is wonderful. The shoes are great and the employees are really helpful.  Users/THEDRO88

20110929 19:50:01 nbsp anyone know why they closed? May have it been lack of great customer service? Users/jsbmeb
  Whats weird is that they did that thing where they said, Just closed for remodeling! but then suddenly a new store opens up with a new owner.   Users/CovertProfessor