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

*   CHAR and ICHAR intrinsics.

C   NONSTANDARD:
C     Use of char constants to initialize numeric.
C     Hex and octal constants (VMS).

	program p
	parameter(n = 11)
	integer rslts(n), expect(n)
	character*4 crslts(n)
	equivalence (rslts, crslts)

	character*1 c1, c2*2, c3*3, c4(2)*4, cfunc

	data c1, c2, c3, c4 / 'a', 'ab', 'abc', 'xyzw', 'XYZW' /
	data i2, i3, i3x    / 2, 3, 3 /

c ----- tests 1 - 8:  ICHAR intrinsic:

	rslts(1) = ichar('\01')
	rslts(2) = ichar( char('377'o) )
	rslts(3) = ichar( char(i2) ) + ichar('a')
	rslts(4) = ichar(c1)
	rslts(5) = ichar( c2(2:2) )
	rslts(6) = ichar( c3(i2:i2) )
	rslts(7) = ichar( c4(i2)(i3:i3x) ) * 2
	rslts(8) = ichar( cfunc(3) )

c ----- tests 9 - 11:  CHAR intrinsic:

	crslts(9) = char('141'o)
	crslts(10) = char(ichar('a'))
	crslts(11) = char(0) // char(i3+i3x) // char(-1) //
     +                char(ifunc(3))

c ----- check results:

	call check(rslts, expect, n)
	data expect / 1, 255, '143'o, '141'o,
     +                '142'o, '142'o, '264'o, 4,
c BIG ENDIAN
c     +                'a   ', 'a   ', '0006FF04'x  /
c LITTLE ENDIAN
     +                'a   ', 'a   ', '04FF0600'x  /
	end
CCCCCCCCCCCCCCCCCC
	character*1 function cfunc(i)
	cfunc = char(i + 1)
	return
	end
CCCCCCCCCCCCCCCCCC
	integer function ifunc (i)
	ifunc = i + 1
	end

ext: f

max_stars_repo_name: kammerdienerb/flang

max_issues_repo_name: kammerdienerb/flang

max_forks_repo_name: kammerdienerb/flang


text:
      SUBROUTINE RDMSGB(LUNIT,MESG,IRET)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    RDMSGB
C   PRGMMR: ATOR             ORG: NP12       DATE: 2005-11-29
C
C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL
C   UNIT LUNIT AS AN ARRAY OF BYTES, WHICH ARE THEN TRANSFERRED TO
C   AN ARRAY OF INTEGER WORDS FOR OUTPUT.
C
C PROGRAM HISTORY LOG:
C 2005-11-29  J. ATOR    -- ORIGINAL AUTHOR
C 2009-03-23  D. KEYSER  -- CALLS BORT IN CASE OF MESG OVERFLOW
C
C USAGE:    CALL RDMSGB (LUNIT, MESG, IRET)
C   INPUT ARGUMENT LIST:
C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C
C   OUTPUT ARGUMENT LIST:
C     MESG     - *-WORD ARRAY CONTAINING BUFR MESSAGE READ FROM LUNIT
C     IRET     - INTEGER: RETURN CODE:
C                       0 = normal return
C                      -1 = end-of-file encountered while reading
C                           from LUNIT
C                      -2 = I/O error encountered while reading
C                           from LUNIT
C
C   INPUT FILES:
C     UNIT "LUNIT" - BUFR FILE
C
C REMARKS:
C    THIS ROUTINE CALLS:        BORT     ICHKSTR  IUPBS01  LMSG
C    THIS ROUTINE IS CALLED BY: None
C                               Normally not called by any application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      INCLUDE 'bufrlib.prm'

      COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)

      DIMENSION   MESG(*)

      CHARACTER*128 BORT_STR
      CHARACTER*8 SEC0
      CHARACTER*1 CBAY(8*MXMSGLD4)
      DIMENSION   JBAY(MXMSGLD4)

      EQUIVALENCE (CBAY(1),JBAY(1),SEC0)

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

      SEC0 = ' '

C     Read Section 0 from the next message in the file.

      READ(LUNIT,END=100,ERR=200) SEC0

C     Confirm that the first 4 bytes contain 'BUFR' encoded in
C     CCITT IA5 (i.e. ASCII).

      IF(ICHKSTR('BUFR',CBAY,4).NE.0) GOTO 200

C     Check the length of the next message to make sure it will fit
C     within the output array.

      LNMSG = LMSG(SEC0)
      IF(LNMSG*NBYTW.GT.MXMSGL) GOTO 900

C     Read the rest of the message as an array of bytes.

      READ(LUNIT,END=100,ERR=200) (CBAY(I),I=9,IUPBS01(JBAY,'LENM'))

C     Transfer the message to the output array.

      DO I=1,LNMSG
        MESG(I) = JBAY(I)
      ENDDO

C  EXITS
C  -----

      IRET = 0
      RETURN

100   IRET = -1
      RETURN

200   IRET = -2
      RETURN

900   WRITE(BORT_STR,'("BUFRLIB: RDMSGB - INPUT BUFR MESSAGE LENGTH (",
     . I6," BYTES) IS LARGER THAN LIMIT OF ",I6," BYTES")')
     . LNMSG*NBYTW,MXMSGL
      CALL BORT(BORT_STR)
      END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
!  ********************************************************************
!  *                                                                  *
!  *                        subroutine plan3d                         *
!  *                                                                  *
!  ********************************************************************
!  Single Precision Version 1.2
!  Written by Gordon A. Fenton, TUNS, Dec. 6, 1993
!  Latest Update: Dec 5, 1996
!
!  PURPOSE   produces stage 1 of the 3-D LAS subdivision in the event that
!            one or two (but not three) of k1, k2, or k3 is equal to 1.
!
!
!  REVISION HISTORY:
!  1.2	explicitly declared dot function types (Dec 5/96)
!--------------------------------------------------------------------------
      subroutine plan3d(Z,iq,jq,k1,k2,k3,AC,AS,AI,CC,CS,CI,U,iout)
      real Z(*), U(*)
      real AC(4,7,*), AS(6,7,*), AI(9,7)
      real CC(28,*), CS(28,*), CI(*)
      logical lk1, lk2, lk3
      real     dot1, dot2, dot3, dot4, dot5, dot6, dot7
      external dot1, dot2, dot3, dot4, dot5, dot6, dot7
      data eight/8.0/

   1  format(a)

      lk1  = (k1 .eq. 1)
      lk2  = (k2 .eq. 1)
      lk3  = (k3 .eq. 1)

      if( .not. lk1 .and. .not. lk2 .and. .not. lk3 ) return

      ix  = 2*k1
      iy  = 2*k2
      ixy = ix*iy
      j0  = jq + 1
      i0  = iq + 1
      i1  = i0 + ix
      i2  = i0 + ixy
      i3  = i2 + ix
!							1-D case

      if( (lk1.and.lk2) .or. (lk1.and.lk3) .or. (lk2.and.lk3) ) then
         jm = max0(k1,k2,k3)
         if( .not. lk1 ) then
            iz = 2
         elseif( .not. lk2 ) then
            iz = 4
         elseif( .not. lk3 ) then
            iz = 8
         else
            write(iout,1)'Can''t subdivide a single cell in plan3d'
            write(iout,1)'(ie. can''t have k1 = k2 = k3 = 1)'
            write(iout,1)'This should never happen!'
            stop
         endif
         call vnorm( U, 7*jm )

         Z(i0)   = AS(1,1,1)*Z(j0) + AS(2,1,1)*Z(j0+1)                    &
                  + CS(1,1)*U(1)
         Z(i0+1) = AS(1,2,1)*Z(j0) + AS(2,2,1)*Z(j0+1)                    &
                  + dot2(CS( 2,1),U(1))
         Z(i1)   = AS(1,3,1)*Z(j0) + AS(2,3,1)*Z(j0+1)                    &
                  + dot3(CS( 4,1),U(1))
         Z(i1+1) = AS(1,4,1)*Z(j0) + AS(2,4,1)*Z(j0+1)                    &
                  + dot4(CS( 7,1),U(1))
         Z(i2)   = AS(1,5,1)*Z(j0) + AS(2,5,1)*Z(j0+1)                    &
                  + dot5(CS(11,1),U(1))
         Z(i2+1) = AS(1,6,1)*Z(j0) + AS(2,6,1)*Z(j0+1)                    &
                  + dot6(CS(16,1),U(1))
         Z(i3)   = AS(1,7,1)*Z(j0) + AS(2,7,1)*Z(j0+1)                    &
                  + dot7(CS(22,1),U(1))
         Z(i1+1) = eight*Z(j0) - Z(i0) - Z(i0+1) - Z(i1)                  &
                    - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
         L = 8
         do 10 js = 1, jm-2
            i0 = i0 + iz
            i1 = i1 + iz
            i2 = i2 + iz
            i3 = i3 + iz
            Z(i0)   = AI(1,1)*Z(j0  )+AI(2,1)*Z(j0+1)+AI(3,1)*Z(j0+2)     &
                   + CI(1)*U(L)
            Z(i0+1) = AI(1,2)*Z(j0  )+AI(2,2)*Z(j0+1)+AI(3,2)*Z(j0+2)     &
                   + dot2(CI(2),U(L))
            Z(i1)   = AI(1,3)*Z(j0  )+AI(2,3)*Z(j0+1)+AI(3,3)*Z(j0+2)     &
                   + dot3(CI(4),U(L))
            Z(i1+1) = AI(1,4)*Z(j0  )+AI(2,4)*Z(j0+1)+AI(3,4)*Z(j0+2)     &
                   + dot4(CI(7),U(L))
            Z(i2)   = AI(1,5)*Z(j0  )+AI(2,5)*Z(j0+1)+AI(3,5)*Z(j0+2)     &
                   + dot5(CI(11),U(L))
            Z(i2+1) = AI(1,6)*Z(j0  )+AI(2,6)*Z(j0+1)+AI(3,6)*Z(j0+2)     &
                   + dot6(CI(16),U(L))
            Z(i3)   = AI(1,7)*Z(j0  )+AI(2,7)*Z(j0+1)+AI(3,7)*Z(j0+2)     &
                   + dot7(CI(22),U(L))
            Z(i1+1) = eight*Z(j0+1) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
            j0 = j0 + 1
            L  = L  + 7
  10     continue
         i0 = i0 + iz
         i1 = i1 + iz
         i2 = i2 + iz
         i3 = i3 + iz
         Z(i0)   = AS(2,1,1)*Z(j0) + AS(1,1,1)*Z(j0+1)                    &
                  + CS(1,1)*U(1)
         Z(i0+1) = AS(2,2,1)*Z(j0) + AS(1,2,1)*Z(j0+1)                    &
                  + dot2(CS( 2,1),U(1))
         Z(i1)   = AS(2,3,1)*Z(j0) + AS(1,3,1)*Z(j0+1)                    &
                  + dot3(CS( 4,1),U(1))
         Z(i1+1) = AS(2,4,1)*Z(j0) + AS(1,4,1)*Z(j0+1)                    &
                  + dot4(CS( 7,1),U(1))
         Z(i2)   = AS(2,5,1)*Z(j0) + AS(1,5,1)*Z(j0+1)                    &
                  + dot5(CS(11,1),U(1))
         Z(i2+1) = AS(2,6,1)*Z(j0) + AS(1,6,1)*Z(j0+1)                    &
                  + dot6(CS(16,1),U(1))
         Z(i3)   = AS(2,7,1)*Z(j0) + AS(1,7,1)*Z(j0+1)                    &
                  + dot7(CS(22,1),U(1))
         Z(i3+1) = eight*Z(j0+1) - Z(i0) - Z(i0+1) - Z(i1)                  &
                    - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
         return
      endif
!							2-D case
      jx = k1
      iz = 2
      if( lk1 ) then
         jx = k2
         iz = 4
      endif
      jy = k3
      if( lk3 ) jy = k2
      j1 = j0 + jx

      call vnorm( U, 7*jx )
!							corner #1
      Z(i0)   = dot4c(Z,AC(1,1,1),CC( 1,1),U(1),dot1,j0,j1)
      Z(i0+1) = dot4c(Z,AC(1,2,1),CC( 2,1),U(1),dot2,j0,j1)
      Z(i1)   = dot4c(Z,AC(1,3,1),CC( 4,1),U(1),dot3,j0,j1)
      Z(i1+1) = dot4c(Z,AC(1,4,1),CC( 7,1),U(1),dot4,j0,j1)
      Z(i2)   = dot4c(Z,AC(1,5,1),CC(11,1),U(1),dot5,j0,j1)
      Z(i2+1) = dot4c(Z,AC(1,6,1),CC(16,1),U(1),dot6,j0,j1)
      Z(i3)   = dot4c(Z,AC(1,7,1),CC(22,1),U(1),dot7,j0,j1)
      Z(i3+1) = eight*Z(j0) - Z(i0) - Z(i0+1) - Z(i1)                     &
                 - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								side #1
      L = 8
      do 40 js = 1, jx-2
         i0 = i0 + iz
         i1 = i1 + iz
         i2 = i2 + iz
         i3 = i3 + iz
         Z(i0)   = dot6h(Z,AS(1,1,1),CS( 1,1),U(L),dot1,j0,j1)
         Z(i0+1) = dot6h(Z,AS(1,2,1),CS( 2,1),U(L),dot2,j0,j1)
         Z(i1)   = dot6h(Z,AS(1,3,1),CS( 4,1),U(L),dot3,j0,j1)
         Z(i1+1) = dot6h(Z,AS(1,4,1),CS( 7,1),U(L),dot4,j0,j1)
         Z(i2)   = dot6h(Z,AS(1,5,1),CS(11,1),U(L),dot5,j0,j1)
         Z(i2+1) = dot6h(Z,AS(1,6,1),CS(16,1),U(L),dot6,j0,j1)
         Z(i3)   = dot6h(Z,AS(1,7,1),CS(22,1),U(L),dot7,j0,j1)
         Z(i3+1) = eight*Z(j0+1) - Z(i0) - Z(i0+1) - Z(i1)                &
                      - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
         j0 = j0 + 1
         j1 = j1 + 1
         L  = L  + 7
  40  continue
!								corner #2
      i0 = i0 + iz
      i1 = i1 + iz
      i2 = i2 + iz
      i3 = i3 + iz
      Z(i0)   = dot4c(Z,AC(1,1,2),CC( 1,2),U(L),dot1,j0,j1)
      Z(i0+1) = dot4c(Z,AC(1,2,2),CC( 2,2),U(L),dot2,j0,j1)
      Z(i1)   = dot4c(Z,AC(1,3,2),CC( 4,2),U(L),dot3,j0,j1)
      Z(i1+1) = dot4c(Z,AC(1,4,2),CC( 7,2),U(L),dot4,j0,j1)
      Z(i2)   = dot4c(Z,AC(1,5,2),CC(11,2),U(L),dot5,j0,j1)
      Z(i2+1) = dot4c(Z,AC(1,6,2),CC(16,2),U(L),dot6,j0,j1)
      Z(i3)   = dot4c(Z,AC(1,7,2),CC(22,2),U(L),dot7,j0,j1)
      Z(i3+1) = eight*Z(j0+1) - Z(i0) - Z(i0+1) - Z(i1)                   &
                   - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

      j0 = jq + 1
      do 60 ks = 1, jy-2
         j1 = j0 + jx
         j2 = j1 + jx
         if( lk3 ) then
            i0 = i1 + 2
         else
            i0 = i3 + 2
         endif
         i1 = i0 + ix
         i2 = i0 + ixy
         i3 = i2 + ix
         call vnorm( U, 7*jx )
!								side #2
         Z(i0)   = dot6v(Z,AS(1,1,2),CS( 1,2),U(1),dot1,j0,j1,j2)
         Z(i0+1) = dot6v(Z,AS(1,2,2),CS( 2,2),U(1),dot2,j0,j1,j2)
         Z(i1)   = dot6v(Z,AS(1,3,2),CS( 4,2),U(1),dot3,j0,j1,j2)
         Z(i1+1) = dot6v(Z,AS(1,4,2),CS( 7,2),U(1),dot4,j0,j1,j2)
         Z(i2)   = dot6v(Z,AS(1,5,2),CS(11,2),U(1),dot5,j0,j1,j2)
         Z(i2+1) = dot6v(Z,AS(1,6,2),CS(16,2),U(1),dot6,j0,j1,j2)
         Z(i3)   = dot6v(Z,AS(1,7,2),CS(22,2),U(1),dot7,j0,j1,j2)
         Z(i3+1) = eight*Z(j1) - Z(i0) - Z(i0+1) - Z(i1)                  &
                    - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								interior
         L = 8
         do 50 js = 1, jx-2
            i0 = i0 + iz
            i1 = i1 + iz
            i2 = i2 + iz
            i3 = i3 + iz
            Z(i0)   = dot9i(Z,AI(1,1),CI( 1),U(L),dot1,j0,j1,j2)
            Z(i0+1) = dot9i(Z,AI(1,2),CI( 2),U(L),dot2,j0,j1,j2)
            Z(i1)   = dot9i(Z,AI(1,3),CI( 4),U(L),dot3,j0,j1,j2)
            Z(i1+1) = dot9i(Z,AI(1,4),CI( 7),U(L),dot4,j0,j1,j2)
            Z(i2)   = dot9i(Z,AI(1,5),CI(11),U(L),dot5,j0,j1,j2)
            Z(i2+1) = dot9i(Z,AI(1,6),CI(16),U(L),dot6,j0,j1,j2)
            Z(i3)   = dot9i(Z,AI(1,7),CI(22),U(L),dot7,j0,j1,j2)
            Z(i3+1) = eight*Z(j1+1) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
            j0 = j0 + 1
            j1 = j1 + 1
            j2 = j2 + 1
            L  = L  + 7
  50     continue
!								side #3
         i0 = i0 + iz
         i1 = i1 + iz
         i2 = i2 + iz
         i3 = i3 + iz
         Z(i0)   = dot6v(Z,AS(1,1,3),CS( 1,3),U(L),dot1,j0,j1,j2)
         Z(i0+1) = dot6v(Z,AS(1,2,3),CS( 2,3),U(L),dot2,j0,j1,j2)
         Z(i1)   = dot6v(Z,AS(1,3,3),CS( 4,3),U(L),dot3,j0,j1,j2)
         Z(i1+1) = dot6v(Z,AS(1,4,3),CS( 7,3),U(L),dot4,j0,j1,j2)
         Z(i2)   = dot6v(Z,AS(1,5,3),CS(11,3),U(L),dot5,j0,j1,j2)
         Z(i2+1) = dot6v(Z,AS(1,6,3),CS(16,3),U(L),dot6,j0,j1,j2)
         Z(i3)   = dot6v(Z,AS(1,7,3),CS(22,3),U(L),dot7,j0,j1,j2)
         Z(i3+1) = eight*Z(j1+1) - Z(i0) - Z(i0+1) - Z(i1)                &
                    - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
         j0 = j0 + 2
  60  continue

      j1 = j0 + jx
      if( lk3 ) then
         i0 = i1 + 2
      else
         i0 = i3 + 2
      endif
      i1 = i0 + ix
      i2 = i0 + ixy
      i3 = i2 + ix
      call vnorm( U, 7*jx )
!								corner #3
      Z(i0)   = dot4c(Z,AC(1,1,3),CC( 1,3),U(1),dot1,j0,j1)
      Z(i0+1) = dot4c(Z,AC(1,2,3),CC( 2,3),U(1),dot2,j0,j1)
      Z(i1)   = dot4c(Z,AC(1,3,3),CC( 4,3),U(1),dot3,j0,j1)
      Z(i1+1) = dot4c(Z,AC(1,4,3),CC( 7,3),U(1),dot4,j0,j1)
      Z(i2)   = dot4c(Z,AC(1,5,3),CC(11,3),U(1),dot5,j0,j1)
      Z(i2+1) = dot4c(Z,AC(1,6,3),CC(16,3),U(1),dot6,j0,j1)
      Z(i3)   = dot4c(Z,AC(1,7,3),CC(22,3),U(1),dot7,j0,j1)
      Z(i3+1) = eight*Z(j1) - Z(i0) - Z(i0+1) - Z(i1)                     &
                 - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								side #4
      L = 8
      do 70 js = 1, jx-2
         i0 = i0 + iz
         i1 = i1 + iz
         i2 = i2 + iz
         i3 = i3 + iz
         Z(i0)   = dot6h(Z,AS(1,1,4),CS( 1,4),U(L),dot1,j0,j1)
         Z(i0+1) = dot6h(Z,AS(1,2,4),CS( 2,4),U(L),dot2,j0,j1)
         Z(i1)   = dot6h(Z,AS(1,3,4),CS( 4,4),U(L),dot3,j0,j1)
         Z(i1+1) = dot6h(Z,AS(1,4,4),CS( 7,4),U(L),dot4,j0,j1)
         Z(i2)   = dot6h(Z,AS(1,5,4),CS(11,4),U(L),dot5,j0,j1)
         Z(i2+1) = dot6h(Z,AS(1,6,4),CS(16,4),U(L),dot6,j0,j1)
         Z(i3)   = dot6h(Z,AS(1,7,4),CS(22,4),U(L),dot7,j0,j1)
         Z(i3+1) = eight*Z(j1+1) - Z(i0) - Z(i0+1) - Z(i1)                &
                      - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
         j0 = j0 + 1
         j1 = j1 + 1
         L  = L  + 7
  70  continue
!								corner #4
      i0 = i0 + iz
      i1 = i1 + iz
      i2 = i2 + iz
      i3 = i3 + iz
      Z(i0)   = dot4c(Z,AC(1,1,4),CC( 1,4),U(L),dot1,j0,j1)
      Z(i0+1) = dot4c(Z,AC(1,2,4),CC( 2,4),U(L),dot2,j0,j1)
      Z(i1)   = dot4c(Z,AC(1,3,4),CC( 4,4),U(L),dot3,j0,j1)
      Z(i1+1) = dot4c(Z,AC(1,4,4),CC( 7,4),U(L),dot4,j0,j1)
      Z(i2)   = dot4c(Z,AC(1,5,4),CC(11,4),U(L),dot5,j0,j1)
      Z(i2+1) = dot4c(Z,AC(1,6,4),CC(16,4),U(L),dot6,j0,j1)
      Z(i3)   = dot4c(Z,AC(1,7,4),CC(22,4),U(L),dot7,j0,j1)
      Z(i3+1) = eight*Z(j1+1) - Z(i0) - Z(i0+1) - Z(i1)                   &
                   - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

      return
      end

max_stars_repo_name: leemargetts/PoreFEM

max_issues_repo_name: leemargetts/PoreFEM

max_forks_repo_name: leemargetts/PoreFEM


text:
Users/PinecrestManager is currently Shirley Dugger, COS. Shirley has been in the property management industry for over 6 years, and is a Davisite herself. The goal in creating this user account is to make management accessible, respond to suggestions/inquiries/complaints honestly, and make sure that the Pinecrest Apartments wiki page is updated with current information for the community.

Welcome to the wiki please consider the importance of using your realname as well as the negative side of apartment manager accounts which can be viewed here http://daviswiki.org/Wiki_Community/Organizational_accounts/Abuse

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
subroutine get_swan_depth (sif,botfil)
!
! Head routine for calling read_bot
!
use swan_flow_grid_maps
implicit none
type(input_fields)          :: sif
character(*)                :: botfil
real                        :: fac =1.
   call read_bot (sif%dps     ,sif%mmax  ,sif%nmax  ,botfil    ,fac )
end subroutine get_swan_depth

subroutine read_bot(dpb       ,mb        ,nb        ,botfil    ,fac  )
!----- 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: get_swan_depth.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/wave/packages/io/src/get_swan_depth.f90 $
!!--description-----------------------------------------------------------------
! NONE
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    implicit none
!
! Global variables
!
    integer                , intent(in)  :: mb
    integer                , intent(in)  :: nb
    real                   , intent(in)  :: fac
    real, dimension(mb, nb)              :: dpb
    character(*)           , intent(in)  :: botfil
!
! Local variables
!
    integer           :: i
    integer           :: j
    integer           :: lunbot
    integer, external :: new_lun
    real              :: dummy
!
!! executable statements -------------------------------------------------------
!
    lunbot = new_lun()
    open (lunbot, file = botfil, status = 'unknown')
    do j = 1, nb
       read (lunbot, *, end = 999) (dpb(i, j), i = 1, mb), dummy
    enddo
    close (lunbot)
    do j = 1, nb
       do i = 1, mb
          dpb(i, j) = dpb(i, j)*fac
       enddo
    enddo
    return
  999 continue
    write (*, '('' Premature end of file while reading file: '',A)') botfil
    close (lunbot)
    stop
end subroutine read_bot

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


!> Module containing interfaces for METIS 5

!> @todo Currently supports only ordering. Should be extended to the other options.

module modmetis
 !based on https://glaros.dtc.umn.edu/gkhome/node/877
 use iso_fortran_env,only:int32
 use iso_c_binding,only:c_int,c_ptr
 implicit none
 private
 public::metis_nodend,metis_setoptions,metis_checkerror

 integer(kind=c_int),parameter::METIS_NOPTIONS=40

 !options, possible values
 integer(kind=c_int),parameter,public::METIS_OPTION_PTYPE=0      ,METIS_PTYPE_RB=0,METIS_PTYPE_KWAY=1
 integer(kind=c_int),parameter,public::METIS_OPTION_OBJTYPE=1    ,METIS_OBJTYPE_CUT=1,METIS_OBJTYPE_VOL=1
 integer(kind=c_int),parameter,public::METIS_OPTION_CTYPE=2      ,METIS_CTYPE_RM=0,METIS_CTYPE_SHEM=1
 integer(kind=c_int),parameter,public::METIS_OPTION_IPTYPE=3     ,METIS_IPTYPE_GROW=0,METIS_IPTYPE_RANDOM=1&
                                                                 ,METIS_IPTYPE_EDGE=2,METIS_IPTYPE_NODE=3
 integer(kind=c_int),parameter,public::METIS_OPTION_RTYPE=4      ,METIS_RTYPE_FM=0,METIS_RTYPE_GREEDY=1&
                                                                 ,METIS_RTYPE_SEP2SIDED=2,METIS_RTYPE_SEP1SIDED=3
 integer(kind=c_int),parameter,public::METIS_OPTION_DBGLVL=5     ,METIS_DBG_INFO=1,METIS_DBG_TIME=2&
                                                                 ,METIS_DBG_COARSEN=4,METIS_DBG_REFINE=8&
                                                                 ,METIS_DBG_IPART=16,METIS_DBG_MOVEINFO=32,METIS_DBG_SEPINFO=64&
                                                                 ,METIS_DBG_CONNINFO=128,METIS_DBG_CONTIGINFO=256
 integer(kind=c_int),parameter,public::METIS_OPTION_NITER=6      !default: 10
 integer(kind=c_int),parameter,public::METIS_OPTION_NCUTS=7      !default: 1
 integer(kind=c_int),parameter,public::METIS_OPTION_SEED=8
 integer(kind=c_int),parameter,public::METIS_OPTION_NO2HOP=9     !0 or 1
 integer(kind=c_int),parameter,public::METIS_OPTION_MINCONN=10   !0 or 1
 integer(kind=c_int),parameter,public::METIS_OPTION_CONTIG=11    !0 or 1
 integer(kind=c_int),parameter,public::METIS_OPTION_COMPRESS=12  !0 or 1
 integer(kind=c_int),parameter,public::METIS_OPTION_CCORDER=13   !0 or 1
 integer(kind=c_int),parameter,public::METIS_OPTION_PFACTOR=14
 integer(kind=c_int),parameter,public::METIS_OPTION_NSEPS=15     !default: 1
 integer(kind=c_int),parameter,public::METIS_OPTION_UFACTOR=16   !default: 1 or 30
 integer(kind=c_int),parameter,public::METIS_OPTION_NUMBERING=17 !0 or 1

 !error values
 integer(kind=c_int),parameter::METIS_OK=1,METIS_ERROR_INPUT=-2,METIS_ERROR_MEMORY=-3,METIS_ERROR=-4

 interface
  function metis_setdefaultoptions(options) result(err) bind(C,name='METIS_SetDefaultOptions')
   import c_int,METIS_NOPTIONS
   integer(kind=c_int),intent(inout)::options(0:METIS_NOPTIONS)
   integer(kind=c_int)::err
  end function
  !METIS_NodND
  !OTPIONS Version 4                   -> Version 5
  ![1] 1(RM) 2(HEM) 3(SHEM)            -> CTYPE
  ![2] 1(edge-based) 2(node-based)     -> ?
  ![3] 1(2-sided node) 2(1-sided node) -> RTYPE
  ![4] 0
  ![5] 0(no compress+no order) 1(compress) 2(order) 3(compress + order) -> COMPRESS +  CCORDER
  ![6] remove vertices                 -> PFACTOR
  ![7] separators                      -> NSEPS
  function metis_nodend(nvtxs,xadj,adjncy,vwgt,options,perm,iperm) result(err) bind(C,name='METIS_NodeND')
   import c_int,c_ptr,METIS_NOPTIONS
   integer(kind=c_int),intent(in)::nvtxs
   integer(kind=c_int),intent(in)::xadj(*),adjncy(*)
   type(c_ptr),intent(in),value::vwgt
   integer(kind=c_int),intent(in)::options(0:METIS_NOPTIONS)   !options is mandatory for Fortran when array start at pos 1
   integer(kind=c_int),intent(out)::perm(*),iperm(*)
   integer(kind=c_int)::err
  end function
 end interface

contains

function metis_setoptions(options&
                           ,ptype,objtype,ctype,iptype,rtype,ncuts&
                           ,nseps,niter,seed,minconn,no2hop,contig&
                           ,compress,ccorder,pfactor,ufactor,dbglvl&
                           ) result(err)
 integer(kind=c_int),allocatable,intent(out)::options(:)
 integer(kind=c_int),intent(in),optional::ptype,objtype,ctype,iptype,rtype,ncuts,&
                                           nseps,niter,seed,minconn,no2hop,&
                                           contig,compress,ccorder,pfactor,ufactor,dbglvl
 integer(kind=c_int)::err

 if(allocated(options))deallocate(options)
 allocate(options(0:METIS_NOPTIONS))

 err=metis_setdefaultoptions(options)
 !DEFAULT
 options(METIS_OPTION_NUMBERING)=1

 !OPTIONAL
 if(present(ptype))options(METIS_OPTION_PTYPE)=ptype
 if(present(objtype))options(METIS_OPTION_OBJTYPE)=objtype
 if(present(ctype))options(METIS_OPTION_CTYPE)=ctype
 if(present(iptype))options(METIS_OPTION_IPTYPE)=iptype
 if(present(rtype))options(METIS_OPTION_RTYPE)=rtype
 if(present(ncuts))options(METIS_OPTION_NCUTS)=ncuts
 if(present(nseps))options(METIS_OPTION_NSEPS)=nseps
 if(present(niter))options(METIS_OPTION_NITER)=niter
 if(present(seed))options(METIS_OPTION_SEED)=seed
 if(present(minconn))options(METIS_OPTION_MINCONN)=minconn
 if(present(no2hop))options(METIS_OPTION_NO2HOP)=no2hop
 if(present(contig))options(METIS_OPTION_CONTIG)=contig
 if(present(compress))options(METIS_OPTION_COMPRESS)=compress
 if(present(ccorder))options(METIS_OPTION_CCORDER)=ccorder
 if(present(pfactor))options(METIS_OPTION_PFACTOR)=pfactor
 if(present(ufactor))options(METIS_OPTION_UFACTOR)=ufactor
 if(present(dbglvl))options(METIS_OPTION_DBGLVL)=dbglvl

end function

subroutine metis_checkerror(err,unlog)
 integer(kind=c_int),intent(in)::err
 integer(kind=int32),intent(in),optional::unlog

 integer(kind=int32)::un

 un=6
 if(present(unlog))un=unlog

 select case(err)
  case(METIS_OK)
   !write(un,'(/a/)')' METIS_OK'
  case(METIS_ERROR_INPUT)
   write(un,'(/a/)')' METIS_ERROR_INPUT'
   stop
  case(METIS_ERROR_MEMORY)
   write(un,'(/a/)')' METIS_ERROR_MEMORY'
   stop
  case(METIS_ERROR)
   write(un,'(/a/)')' METIS_ERROR'
   stop
  case default
   write(un,'(/a/)')' UNKNOWN METIS_ERROR'
   stop
 end select

end subroutine

end module


text:
C    %W% %G%
        subroutine prterr (errtyp, nbl)

C       PRTERR prints the error message in a uniform format and
C       maintains a count in errcnt of  the numbers of errors at
C       each severity level. It reformats the error text and calls
C       the print routine for actual printing of the messages.

C       The error message is also saved in common /ERRMSG/ERRM(LIMERR)
C       for summarizing at the end of the swing output.

C       ERRTYP - a character designating the severity level:

C              I - informative
C              W - warning
C              E - error
C              A - abort

C       NBL - the number of lines encoded in ERRBUF
C

      include 'tspinc/prt.inc'
      include 'tspinc/pageno.inc'
      include 'tspinc/topbot.inc'
      include 'tspinc/errmsg.inc'

        character errtyp*1
        character *12 errflg(5)
        character crgctl*1
        integer type, savcrt, svlprt
        integer errno
        data errflg /'*INFORMATIVE','*** WARNING ','*** ERROR   ',
     1     '*** FATAL   ','*** ABORT   '/
C * * *
C* *  *   SAVE LPRT & CRT SWITCHS AND TURN THEM ON..
C * * *
        svlprt  = lprtsw
        savcrt  = crtsw
        lprtsw  = 1
        crtsw = 1
        type = 0

        type=index('IWEFA',errtyp)

        if(type.ne.0) then

           errcnt(type)=errcnt(type)+1

C          DON'T PRINT ERROR LEVEL 1 ON CRT OR LPT OR FICHE
C               (defer to end of pf reports)
C
           if(type.eq.1) then
              lprtsw=0
              crtsw=0
              fichsw=0
           endif

        else
           write (outbuf,140) errtyp
  140      format ('0 ILLEGAL ERROR TYPE ',a,' SET TO "I"')
           type = 1
           outbuf(122:) = errflg(type)
           call prtout (1)
        endif

C***   PRINT LINES OF ERROR MESSAGE

        do 60 i = 1,nbl
        if (i .eq. 1) then
           if(errbuf(1)(1:1).eq.'0') then
              crgctl = '0'
              errbuf(1)(1:1) = ' '
           else
              crgctl = ' '
           endif
        else
           crgctl = ' '
        endif
        write (outbuf,150) crgctl,errflg(type),errbuf(i)(1:106),
     1     errflg(type)
  150   format(a1,a12,1x,a,1x,a12)
        call prtout (1)
        if (numerr .lt. LIMERR) then
            numerr=numerr+1
            errm(numerr)=outbuf
        endif
  60    continue

        if (errcnt(2)+errcnt(3)+errcnt(4) .eq. LIMERR) then
           write (lprt,165) LIMERR
165        format(1x,'PRTERR MORE THAN ',i4,' ERRORS. ERROR SUMMARY',
     1     ' IS ABORTED.---WARNING')
        endif

C***                    RESTORE LPRT & CRT SWITCHES TO ORIG. VALUE

        crtsw  = savcrt
        lprtsw = svlprt

        return
        end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
*DECK DBESJ1
      DOUBLE PRECISION FUNCTION DBESJ1 (X)
C***BEGIN PROLOGUE  DBESJ1
C***PURPOSE  Compute the Bessel function of the first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      DOUBLE PRECISION (BESJ1-S, DBESJ1-D)
C***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBESJ1(X) calculates the double precision Bessel function of the
C first kind of order one for double precision argument X.
C
C Series for BJ1        on the interval  0.          to  1.60000E+01
C                                        with weighted error   1.16E-33
C                                         log weighted error  32.93
C                               significant figures required  32.36
C                                    decimal places required  33.57
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9B1MP, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   910401  Corrected error in code which caused values to have the
C           wrong sign for arguments less than 4.0.  (WRB)
C***END PROLOGUE  DBESJ1
      DOUBLE PRECISION X, BJ1CS(19), AMPL, THETA, XSML, XMIN, Y,
     1  D1MACH, DCSEVL
      LOGICAL FIRST
      SAVE BJ1CS, NTJ1, XSML, XMIN, FIRST
      DATA BJ1CS(  1) / -.1172614151 3332786560 6240574524 003 D+0    /
      DATA BJ1CS(  2) / -.2536152183 0790639562 3030884554 698 D+0    /
      DATA BJ1CS(  3) / +.5012708098 4469568505 3656363203 743 D-1    /
      DATA BJ1CS(  4) / -.4631514809 6250819184 2619728789 772 D-2    /
      DATA BJ1CS(  5) / +.2479962294 1591402453 9124064592 364 D-3    /
      DATA BJ1CS(  6) / -.8678948686 2788258452 1246435176 416 D-5    /
      DATA BJ1CS(  7) / +.2142939171 4379369150 2766250991 292 D-6    /
      DATA BJ1CS(  8) / -.3936093079 1831797922 9322764073 061 D-8    /
      DATA BJ1CS(  9) / +.5591182317 9468800401 8248059864 032 D-10   /
      DATA BJ1CS( 10) / -.6327616404 6613930247 7695274014 880 D-12   /
      DATA BJ1CS( 11) / +.5840991610 8572470032 6945563268 266 D-14   /
      DATA BJ1CS( 12) / -.4482533818 7012581903 9135059199 999 D-16   /
      DATA BJ1CS( 13) / +.2905384492 6250246630 6018688000 000 D-18   /
      DATA BJ1CS( 14) / -.1611732197 8414416541 2118186666 666 D-20   /
      DATA BJ1CS( 15) / +.7739478819 3927463729 8346666666 666 D-23   /
      DATA BJ1CS( 16) / -.3248693782 1119984114 3466666666 666 D-25   /
      DATA BJ1CS( 17) / +.1202237677 2274102272 0000000000 000 D-27   /
      DATA BJ1CS( 18) / -.3952012212 6513493333 3333333333 333 D-30   /
      DATA BJ1CS( 19) / +.1161678082 2664533333 3333333333 333 D-32   /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBESJ1
      IF (FIRST) THEN
         NTJ1 = INITDS (BJ1CS, 19, 0.1*REAL(D1MACH(3)))
C
         XSML = SQRT(8.0D0*D1MACH(3))
         XMIN = 2.0D0*D1MACH(1)
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.4.0D0) GO TO 20
C
      DBESJ1 = 0.0D0
      IF (Y.EQ.0.0D0) RETURN
      IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBESJ1',
     +   'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1)
      IF (Y.GT.XMIN) DBESJ1 = 0.5D0*X
      IF (Y.GT.XSML) DBESJ1 = X*(.25D0 + DCSEVL (.125D0*Y*Y-1.D0,
     1  BJ1CS, NTJ1) )
      RETURN
C
 20   CALL D9B1MP (Y, AMPL, THETA)
      DBESJ1 = SIGN (AMPL, X) * COS(THETA)
C
      RETURN
      END

max_stars_repo_name: ygeorgi/MESS

max_issues_repo_name: ygeorgi/MESS

max_forks_repo_name: ygeorgi/MESS


module converr_uv
!$$$   module documentation block
!                .      .    .                                       .
! module:    converr_uv
!   prgmmr: su          org: np2                date: 2007-03-15
! abstract:  This module contains variables and routines related
!            to the assimilation of conventional observations error
!
! program history log:
!   2007-03-15  su  - original code - move reading observation error table
!                                     from read_prepbufr to here so all the
!                                     processor can have the new error information
!
! Subroutines Included:
!   sub converr_uv_read      - allocate arrays for and read in conventional error table
!   sub converr_uv_destroy   - destroy conventional error arrays
!
! Variable Definitions:
!   def etabl_uv             -  the array to hold the error table
!   def ptabl_uv             -  the array to have vertical pressure values
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

use kinds, only:r_kind,i_kind,r_single
use constants, only: zero
use obsmod, only : oberrflg
implicit none

! set default as private
  private
! set subroutines as public
  public :: converr_uv_read
  public :: converr_uv_destroy
! set passed variables as public
  public :: etabl_uv,ptabl_uv,isuble_uv,maxsub_uv

  integer(i_kind),save:: ietabl_uv,itypex,itypey,lcount,iflag,k,m,n,maxsub_uv
  real(r_single),save,allocatable,dimension(:,:,:) :: etabl_uv
  real(r_kind),save,allocatable,dimension(:)  :: ptabl_uv
  integer(i_kind),save,allocatable,dimension(:,:)  :: isuble_uv

contains

  subroutine converr_uv_read(mype)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    convinfo_err      read conventional information file
!
!     prgmmr:    su    org: np2                date: 2007-03-15
!
! abstract:  This routine reads the conventional error table file
!
! program history log:
!   2008-06-04  safford -- add subprogram doc block
!   2013-05-14  guo     -- add status and iostat in open, to correctly
!                          handle the error case of "obs error table not
!                          available to 3dvar".
!   2015-03-06  yang    -- add ld=300, the size of the error table.
!                          Remove the original calculation to get error table array
!                          index. ld=300 is sufficient for current conventional
!                          observing systems.
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block
     use constants, only: half
     implicit none
     integer(i_kind),parameter    :: ld=300
     integer(i_kind),intent(in   ) :: mype
     integer(i_kind):: ier

     allocate(etabl_uv(ld,33,8),isuble_uv(ld,7))

     etabl_uv=1.e9_r_kind
     maxsub_uv=7

     ietabl_uv=19
     open(ietabl_uv,file='errtable_uv',form='formatted',status='old',iostat=ier)
     if(ier/=0) then
        write(6,*)'CONVERR_uv:  ***WARNING*** obs error table ("errtable") not available to 3dvar.'
        lcount=0
        oberrflg=.false.
        return
     endif

     rewind ietabl_uv
     etabl_uv=1.e9_r_kind
     lcount=0
     loopd : do
        read(ietabl_uv,100,IOSTAT=iflag,end=120) itypey
        if( iflag /= 0 ) exit loopd
!        if (mype == 0) write(6,*)'CONVERR_UV:itypey=',itypey
100     format(1x,i3)
        lcount=lcount+1
        itypex=itypey
        read(ietabl_uv,105,IOSTAT=iflag,end=120) (isuble_uv(itypex,n),n=1,7)
!        if (mype == 0) write(6,*)'CONVERR_UV:itypex,itypex=',itypex,itypex
105     format(8x,7i12)
        do k=1,33
           read(ietabl_uv,110)(etabl_uv(itypex,k,m),m=1,8)
110        format(1x,8e12.5)
        end do
     end do   loopd
120  continue
     if(lcount<=0 .and. mype==0) then
        write(6,*)'CONVERR_UV:  ***WARNING*** obs error table not available to 3dvar.'
        oberrflg=.false.
     else
        if(mype == 0) then
           write(6,*)'CONVERR_UV:  using observation errors from user provided table'
        endif
        allocate(ptabl_uv(34))

! use the pressure values of itypex, which is the last valid observation type.
        if (itypex > 0 ) then
           ptabl_uv=zero
           ptabl_uv(1)=etabl_uv(itypex,1,1)
           do k=2,33
              ptabl_uv(k)=half*(etabl_uv(itypex,k-1,1)+etabl_uv(itypex,k,1))
           enddo
           ptabl_uv(34)=etabl_uv(itypex,33,1)
         else
            write(6,*)'ERROR IN CONVERR_UV: NO OBSERVATION TYPE READ IN'
            return
         endif
     endif

     close(ietabl_uv)

     return
  end subroutine converr_uv_read

subroutine converr_uv_destroy
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    converr_uv_destroy      destroy conventional information file
!     prgmmr:    su    org: np2                date: 2007-03-15
!
! abstract:  This routine destroys arrays from converr_uv file
!
! program history log:
!   2007-03-15  su
!
!   input argument list:
!
!   output argument list:
!
! atte#ibutes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
     implicit none

     deallocate(etabl_uv,ptabl_uv,isuble_uv)
     return
  end subroutine converr_uv_destroy

end module converr_uv


text:
Westlake Plaza Shopping Center is a West Davis Shopping Centers shopping center. It was formerly known as Farm Town Center. The Westlake Market anchors the shopping center since 2010.

The City of Davis General Plan of May 2001, Section IV, Chapter 1, encourages shopping opportunities to meet Davis residents daily needs in areas conveniently located to each neighborhood. The city supports many smaller neighborhood commercial centers each at a focal point instead of fewer larger centers.

Westlake stores provide a wide range of services to West Davis residents. Westlake was built by Al Smith who reportedly came to Davis in the early 1970s via Beverly Hills. Purportedly, he proceeded to invest (and lose) his entire inheritance in the building of Stonegate Country Club, Stonegate subdivision, and Westlake Shopping Center. Unfortunately, Mr. Smith did not profit from his vision. He seems to be a man ahead of his times, as this area of West Davis continues to be one of the most well planned and sought after neighborhoods in Davis. Stonegate also boasts a wide range of housing types and sizes unlike the newer additions of Mace Ranch and Wildhorse subdivisions.

The Westlake Plaza is served by the Unitrans D Bus Line D and K Bus Line K lines on Lake Boulevard and on Arlington Boulevard Arlington, and by the P/Q bus line on Arlington.

A nonprofit group, Davis Advocates for Neighborhood Groceries (DANG), was formed to coordinate efforts to locate fullservice grocery store in the Westlake Plaza Shopping Center. A petition urging the City Council not to allow the center landlord to convert most of the former market space to offices garnered more than 1,000 signatures of local residents. Read more about the groups activities at http://groups.dcn.org/dang their website.

Stores in Westlake Plaza include:

  Aaranna Hair Design
  Abba Salon and Spa
  AMD Medical Supply  Stethoscopes, scrubs & accessories for healthcare professionals, compression garments, wheelchairs, walkers, bath chairs, hospital beds, lift chairs,etc.
  Chuys Taqueria
  Curves
  Davis Airporter
  Davis Christian Bookroom
  Family Dollar
  Feldspar Pet Spa
  Lamppost Pizza
  Modern Nails
  S&S Computer Repair
  Shanghai Town
  xSoap City Laundromatx
  Star Cleaners
  Stonegate Video (actually Stonegate Cafe and Video, a video rental store, bakery and java bar allinone)
  UHaul Rental
  Westlake Market opened Jan. 15, 2010

20061114 02:00:59 nbsp I went to a meeting tonight at Stonegate Country Club about new stuff going into the grocery space in this shopping center. A smaller grocery store is planned and the rest of the space will be filled by more retail on the Arlington Boulevard Arlington side and offices in the back. I said at the meeting that I thought there should be a 24 hour donut or coffee shop because people already go to Java California in Dixon. Apparently alot of the Stonegate people dont want a 24 hour place, so it would be great if more people who would also like that could come to future meetings about this development. I put my name and address on their list, so I should receive future announcements, and will put them here.  Users/NickSchmalenberger

  20070405 23:29:42 nbsp Please do, Nick. I live right next door to the shopping center and its felt kinda lifeless since Food Fair (for all its faults...) left. Did this meeting specify a timeline for adding new businesses to the center? Users/StacieTownsend

20071201 18:08:51 nbsp An indoor velodrome would be cool here. The building probably isnt big enough, but it could be.  Users/MischaGushiken

20080421 13:09:32 nbsp There is currently (April 2008) a petition in the coffee shop (Stonegate Video) asking the council to reserve that space for grocery stores only, and not to split the space into smaller lots for other retail businesses and offices. Any residents (and possibly anyone? I dont know how it works) should go sign the petition if they want larger grocery stores to come into the area.  Users/ElleWeber

20080422 00:23:57 nbsp I have been to several of the meetings at Stonegate Country Club about this space and it is clear to me the reason why it has been empty so long is that the Stonegate residents are much too demanding. I have lived around there, east of the shopping center for all my life and shopped at Farmtown, Rays, and Food Fair. Many people at the meetings said Food Fair was not good, but I was always very happy with the service and the employees were very nice. However, space and goods both cost money so to have more of both there will need to be alot more money coming in. That probably isnt going to happen unless something like the West Village gets developed because more development north of West Davis will find it easier to go to Safeway. I was also at one of the meetings for West Village, and again, the West Davis residents were much too demanding. At the first meeting I went to at the Country Club, the owners of Food Fair were there talking about their new plans. When it came out that they had run Food Fair many in the audience became angry because they were so unsatisfied with Food Fair (not me), and the Food Fair people were not at the second meeting I went to. Sad. The only Stonegate Resident who actually had experience running a grocery store at the meeting was Al Smith, and he blamed Safeway and its violation of the Davis grocery store zoning laws for Farmtown and later stores failure. His accusation was true, but also long in the past, so now somebody needs to have a store that complements Safeway and will be sustainable by the customers it would get in that location. The proposals for this have been rejected and the property owner has been criticized for all sorts of things about the upkeep of the center, when the real issue is there is no grocery store there because of the high expectations of the very same complainants. How much worse could the proposals be than the present state? Users/NickSchmalenberger

20080520 12:32:10 nbsp It would be awesome if there was a Trader Joes here.  I think that would complement the rest of the grocery stores in Davis. Users/jackson
  20080626 23:08:25 nbsp According to City staff and the landlord (at a Planning Commission meeting in January 2008) Trader Joes has been asked about this site and turned it down. It really doesnt fit the site selection criteria they use for most of their dozens & dozens of California stores, IMO. Users/DougWalter

20080823 12:27:17 nbsp Please dont buy into the landlords something is better than nothing fallacy. Visit the davisdang.org http://www.davisdang.org website and read the FAQs. A creative solution is out there. Communities all across the country, working together, are discovering them nearly every day. Users/russellsnyder

20090830 21:06:48 nbsp Delanos IGA of San Rafael, California has announced that they are going to open a new grocery store. http://www.delanomarkets.com/ Users/MaxLucas

  20090914 21:19:07 nbsp Seriously?! Hurray! Users/vladthedestroyer


text:
                   SSUUMMMMAARRYY OOFF LLEESSSS CCOOMMMMAANNDDSS

      Commands marked with * may be preceded by a number, _N.
      Notes in parentheses indicate the behavior if _N is given.
      A key preceded by a caret indicates the Ctrl key; thus ^K is ctrl-K.

  h  H                 Display this help.
  q  :q  Q  :Q  ZZ     Exit.
 ---------------------------------------------------------------------------

                           MMOOVVIINNGG

  e  ^E  j  ^N  CR  *  Forward  one line   (or _N lines).
  y  ^Y  k  ^K  ^P  *  Backward one line   (or _N lines).
  f  ^F  ^V  SPACE  *  Forward  one window (or _N lines).
  b  ^B  ESC-v      *  Backward one window (or _N lines).
  z                 *  Forward  one window (and set window to _N).
  w                 *  Backward one window (and set window to _N).
  ESC-SPACE         *  Forward  one window, but don't stop at end-of-file.
  d  ^D             *  Forward  one half-window (and set half-window to _N).
  u  ^U             *  Backward one half-window (and set half-window to _N).
  ESC-)  RightArrow *  Right one half screen width (or _N positions).
  ESC-(  LeftArrow  *  Left  one half screen width (or _N positions).
  ESC-}  ^RightArrow   Right to last column displayed.
  ESC-{  ^LeftArrow    Left  to first column.
  F                    Forward forever; like "tail -f".
  ESC-F                Like F but stop when search pattern is found.
  r  ^R  ^L            Repaint screen.
  R                    Repaint screen, discarding buffered input.
        ---------------------------------------------------
        Default "window" is the screen height.
        Default "half-window" is half of the screen height.
 ---------------------------------------------------------------------------

                          SSEEAARRCCHHIINNGG

  /_p_a_t_t_e_r_n          *  Search forward for (_N-th) matching line.
  ?_p_a_t_t_e_r_n          *  Search backward for (_N-th) matching line.
  n                 *  Repeat previous search (for _N-th occurrence).
  N                 *  Repeat previous search in reverse direction.
  ESC-n             *  Repeat previous search, spanning files.
  ESC-N             *  Repeat previous search, reverse dir. & spanning files.
  ESC-u                Undo (toggle) search highlighting.
  &_p_a_t_t_e_r_n          *  Display only matching lines
        ---------------------------------------------------
        A search pattern may be preceded by one or more of:
        ^N or !  Search for NON-matching lines.
        ^E or *  Search multiple files (pass thru END OF FILE).
        ^F or @  Start search at FIRST file (for /) or last file (for ?).
        ^K       Highlight matches, but don't move (KEEP position).
        ^R       Don't use REGULAR EXPRESSIONS.
 ---------------------------------------------------------------------------

                           JJUUMMPPIINNGG

  g  <  ESC-<       *  Go to first line in file (or line _N).
  G  >  ESC->       *  Go to last line in file (or line _N).
  p  %              *  Go to beginning of file (or _N percent into file).
  t                 *  Go to the (_N-th) next tag.
  T                 *  Go to the (_N-th) previous tag.
  {  (  [           *  Find close bracket } ) ].
  }  )  ]           *  Find open bracket { ( [.
  ESC-^F _<_c_1_> _<_c_2_>  *  Find close bracket _<_c_2_>.
  ESC-^B _<_c_1_> _<_c_2_>  *  Find open bracket _<_c_1_>
        ---------------------------------------------------
        Each "find close bracket" command goes forward to the close bracket
          matching the (_N-th) open bracket in the top line.
        Each "find open bracket" command goes backward to the open bracket
          matching the (_N-th) close bracket in the bottom line.

  m_<_l_e_t_t_e_r_>            Mark the current top line with <letter>.
  M_<_l_e_t_t_e_r_>            Mark the current bottom line with <letter>.
  '_<_l_e_t_t_e_r_>            Go to a previously marked position.
  ''                   Go to the previous position.
  ^X^X                 Same as '.
  ESC-M_<_l_e_t_t_e_r_>        Clear a mark.
        ---------------------------------------------------
        A mark is any upper-case or lower-case letter.
        Certain marks are predefined:
             ^  means  beginning of the file
             $  means  end of the file
 ---------------------------------------------------------------------------

                        CCHHAANNGGIINNGG FFIILLEESS

  :e [_f_i_l_e]            Examine a new file.
  ^X^V                 Same as :e.
  :n                *  Examine the (_N-th) next file from the command line.
  :p                *  Examine the (_N-th) previous file from the command line.
  :x                *  Examine the first (or _N-th) file from the command line.
  :d                   Delete the current file from the command line list.
  =  ^G  :f            Print current file name.
 ---------------------------------------------------------------------------

                    MMIISSCCEELLLLAANNEEOOUUSS CCOOMMMMAANNDDSS

  -_<_f_l_a_g_>              Toggle a command line option [see OPTIONS below].
  --_<_n_a_m_e_>             Toggle a command line option, by name.
  __<_f_l_a_g_>              Display the setting of a command line option.
  ___<_n_a_m_e_>             Display the setting of an option, by name.
  +_c_m_d                 Execute the less cmd each time a new file is examined.

  !_c_o_m_m_a_n_d             Execute the shell command with $SHELL.
  |XX_c_o_m_m_a_n_d            Pipe file between current pos & mark XX to shell command.
  s _f_i_l_e               Save input to a file.
  v                    Edit the current file with $VISUAL or $EDITOR.
  V                    Print version number of "less".
 ---------------------------------------------------------------------------

                           OOPPTTIIOONNSS

        Most options may be changed either on the command line,
        or from within less by using the - or -- command.
        Options may be given in one of two forms: either a single
        character preceded by a -, or a name preceded by --.

  -?  ........  --help
                  Display help (from command line).
  -a  ........  --search-skip-screen
                  Search skips current screen.
  -A  ........  --SEARCH-SKIP-SCREEN
                  Search starts just after target line.
  -b [_N]  ....  --buffers=[_N]
                  Number of buffers.
  -B  ........  --auto-buffers
                  Don't automatically allocate buffers for pipes.
  -c  ........  --clear-screen
                  Repaint by clearing rather than scrolling.
  -d  ........  --dumb
                  Dumb terminal.
  -D [_x_n_._n]  .  --color=_x_n_._n
                  Set screen colors. (MS-DOS only)
  -e  -E  ....  --quit-at-eof  --QUIT-AT-EOF
                  Quit at end of file.
  -f  ........  --force
                  Force open non-regular files.
  -F  ........  --quit-if-one-screen
                  Quit if entire file fits on first screen.
  -g  ........  --hilite-search
                  Highlight only last match for searches.
  -G  ........  --HILITE-SEARCH
                  Don't highlight any matches for searches.
  -h [_N]  ....  --max-back-scroll=[_N]
                  Backward scroll limit.
  -i  ........  --ignore-case
                  Ignore case in searches that do not contain uppercase.
  -I  ........  --IGNORE-CASE
                  Ignore case in all searches.
  -j [_N]  ....  --jump-target=[_N]
                  Screen position of target lines.
  -J  ........  --status-column
                  Display a status column at left edge of screen.
  -k [_f_i_l_e]  .  --lesskey-file=[_f_i_l_e]
                  Use a lesskey file.
  -K            --quit-on-intr
                  Exit less in response to ctrl-C.
  -L  ........  --no-lessopen
                  Ignore the LESSOPEN environment variable.
  -m  -M  ....  --long-prompt  --LONG-PROMPT
                  Set prompt style.
  -n  -N  ....  --line-numbers  --LINE-NUMBERS
                  Don't use line numbers.
  -o [_f_i_l_e]  .  --log-file=[_f_i_l_e]
                  Copy to log file (standard input only).
  -O [_f_i_l_e]  .  --LOG-FILE=[_f_i_l_e]
                  Copy to log file (unconditionally overwrite).
  -p [_p_a_t_t_e_r_n]  --pattern=[_p_a_t_t_e_r_n]
                  Start at pattern (from command line).
  -P [_p_r_o_m_p_t]   --prompt=[_p_r_o_m_p_t]
                  Define new prompt.
  -q  -Q  ....  --quiet  --QUIET  --silent --SILENT
                  Quiet the terminal bell.
  -r  -R  ....  --raw-control-chars  --RAW-CONTROL-CHARS
                  Output "raw" control characters.
  -s  ........  --squeeze-blank-lines
                  Squeeze multiple blank lines.
  -S  ........  --chop-long-lines
                  Chop (truncate) long lines rather than wrapping.
  -t [_t_a_g]  ..  --tag=[_t_a_g]
                  Find a tag.
  -T [_t_a_g_s_f_i_l_e] --tag-file=[_t_a_g_s_f_i_l_e]
                  Use an alternate tags file.
  -u  -U  ....  --underline-special  --UNDERLINE-SPECIAL
                  Change handling of backspaces.
  -V  ........  --version
                  Display the version number of "less".
  -w  ........  --hilite-unread
                  Highlight first new line after forward-screen.
  -W  ........  --HILITE-UNREAD
                  Highlight first new line after any forward movement.
  -x [_N[,...]]  --tabs=[_N[,...]]
                  Set tab stops.
  -X  ........  --no-init
                  Don't use termcap init/deinit strings.
  -y [_N]  ....  --max-forw-scroll=[_N]
                  Forward scroll limit.
  -z [_N]  ....  --window=[_N]
                  Set size of window.
  -" [_c[_c]]  .  --quotes=[_c[_c]]
                  Set shell quote characters.
  -~  ........  --tilde
                  Don't display tildes after end of file.
  -# [_N]  ....  --shift=[_N]
                  Horizontal scroll amount (0 = one half screen width)
      ........  --no-keypad
                  Don't send termcap keypad init/deinit strings.
      ........  --follow-name
                  The F command changes files if the input file is renamed.
      ........  --use-backslash
                  Subsequent options use backslash as escape char.

 ---------------------------------------------------------------------------

                          LLIINNEE EEDDIITTIINNGG

        These keys can be used to edit text being entered
        on the "command line" at the bottom of the screen.

 RightArrow ..................... ESC-l ... Move cursor right one character.
 LeftArrow ...................... ESC-h ... Move cursor left one character.
 ctrl-RightArrow  ESC-RightArrow  ESC-w ... Move cursor right one word.
 ctrl-LeftArrow   ESC-LeftArrow   ESC-b ... Move cursor left one word.
 HOME ........................... ESC-0 ... Move cursor to start of line.
 END ............................ ESC-$ ... Move cursor to end of line.
 BACKSPACE ................................ Delete char to left of cursor.
 DELETE ......................... ESC-x ... Delete char under cursor.
 ctrl-BACKSPACE   ESC-BACKSPACE ........... Delete word to left of cursor.
 ctrl-DELETE .... ESC-DELETE .... ESC-X ... Delete word under cursor.
 ctrl-U ......... ESC (MS-DOS only) ....... Delete entire line.
 UpArrow ........................ ESC-k ... Retrieve previous command line.
 DownArrow ...................... ESC-j ... Retrieve next command line.
 TAB ...................................... Complete filename & cycle.
 SHIFT-TAB ...................... ESC-TAB   Complete filename & reverse cycle.
 ctrl-L ................................... Complete filename, list all.

max_stars_repo_path: itory exists.f

max_stars_repo_name: Qcc/cloudAdmin

max_issues_repo_path: itory exists.f

max_issues_repo_name: Qcc/cloudAdmin

max_forks_repo_path: itory exists.f

max_forks_repo_name: Qcc/cloudAdmin