text:
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE MP3PG(NV,XV,YV,ZV,NO,XVO,YVO,ZVO)
      COMMON /MAP/MODEL(4,4),VIEW(4,4),PROJ(4,4),CPNEAR,CPFAR,VWPORT(4),
     *       MVP(4,4),VP(4,4),CPLINE(2,2,10),CPPLAN(2,3,10),PEYE(3),
     *       PLOOK(3),ETWIST,NCPLIN,NCPLAN,TMAT1(4,4),TMAT2(4,4),
     *       TMAT3(4,4),TVEC1(4),TVEC2(4),TVEC3(4),TVEC4(4),TARR1(32),
     *       TARR2(32),TARR3(32),TARR4(32),TARR5(32),TARR6(32),
     *       TARR7(32),TARR8(32)
      REAL MODEL,MVP
      LOGICAL NOCLIP
      DIMENSION C1(3),C2(3),XV(NV),YV(NV),ZV(NV),XVO(NO),YVO(NO),ZVO(NO)
      dimension mask(1)

      VCX = (VWPORT(1)+VWPORT(2))/2.
      VSX = (VWPORT(2)-VWPORT(1))/2.
      VCY = (VWPORT(3)+VWPORT(4))/2.
      VSY = (VWPORT(4)-VWPORT(3))/2.
      NOCLIP = (NCPLAN.EQ.0)
      NOSAVE = NO
      NO = 0
      MASK(1) = -1
      IF (NOCLIP) THEN
         CALL MPMUL3(NV,XV,YV,ZV,MVP,TARR1,TARR2,TARR3,TARR4)

      ELSE
         CALL MPMUL3(NV,XV,YV,ZV,MODEL,TARR1,TARR2,TARR3,TARR4)
         DO 2220 I = 1,NCPLAN
            C1(1) = CPPLAN(1,1,I)
            C1(2) = CPPLAN(1,2,I)
            C1(3) = CPPLAN(1,3,I)
            C2(1) = CPPLAN(2,1,I)
            C2(2) = CPPLAN(2,2,I)
            C2(3) = CPPLAN(2,3,I)
            CALL PLTCP3(NV,MASK,TARR1,TARR2,TARR3,C1,C2)
            IF (MASK(1).NE.-1) THEN
               GO TO 2220

            END IF

 2220    CONTINUE
         CALL MPMUL4(NV,MASK(1),TARR1,TARR2,TARR3,TARR4,VP,TARR1,TARR2,
     *               TARR3,TARR4)
      END IF

      CALL PLTZCP(CPNEAR,CPFAR,NV,MASK,TARR4)
      IF (MASK(1).NE.-1) THEN
         RETURN

      END IF

      DO 2240 I = 1,NV
         TARR1(I) = (TARR1(I)/TARR4(I))*VSX + VCX
         TARR2(I) = (TARR2(I)/TARR4(I))*VSY + VCY
         TARR3(I) = TARR3(I)/TARR4(I)
 2240 CONTINUE
      C1(1) = VWPORT(1)
      C1(2) = VWPORT(3)
      C2(1) = VWPORT(2)
      C2(2) = VWPORT(4)
      NO = NOSAVE
      CALL PLTVWG(C1,C2,NV,TARR1,TARR2,TARR3,NO,XVO,YVO,ZVO)
      RETURN

      END

ext: f

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
      SUBROUTINE HISTOGRAM2D(N,X,Y,Z,NXBINS,NYBINS,XLIM,YLIM,DX,DY,
     1  NST,HST)

Cf2py intent(in) n
Cf2py intent(in) x
Cf2py depend(n) x
Cf2py intent(in) y
Cf2py depend(n) y
Cf2py intent(in) z
Cf2py depend(n) z
Cf2py intent(in) nxbins
Cf2py intent(in) nybins
Cf2py intent(in) xlim
Cf2py intent(in) ylim
Cf2py intent(in) dx
Cf2py intent(in) dy
Cf2py intent(in,out) nst
Cf2py depend(nxbins,nybins) nst
Cf2py intent(in,out) hst
Cf2py depend(nxbins,nybins) hst

      IMPLICIT NONE
      INTEGER*8   N
      REAL*4      X(0:N-1),Y(0:N-1),Z(0:N-1)
      INTEGER*8   NXBINS,NYBINS
      REAL*8      XLIM(0:1),YLIM(0:1)
      REAL*4      NST(0:NXBINS-1,0:NYBINS-1)
      REAL*4      HST(0:NXBINS-1,0:NYBINS-1)

      INTEGER*4   I,J,K
      REAL*8      DX,DY
      REAL*4      DDX,DDY
      DO K=0,N-1
C        if ( mod(k,8000) .eq. 0 )
C     1    print *,k,x(k),xlim,y(k),ylim
        IF ( ( X(K).GE.XLIM(0) .AND. X(K).LT.XLIM(1) ) .AND.
     1    ( Y(K).GE.YLIM(0) .AND. Y(K).LT.YLIM(1) )) THEN
          DDX = (X(K)-XLIM(0))/DX
          I = MIN(MAX(0,INT(DDX)),NXBINS-1)
          DDY = (Y(K)-YLIM(0))/DY
          J = MIN(MAX(0,INT(DDY)),NYBINS-1)
          NST(I,J) = NST(I,J)+1.0
          HST(I,J) = HST(I,J)+Z(K)
C          if ( mod(k,8000) .eq. 0 )
C     1      print *,i,j,nst(i,j),hst(i,j)
        END IF
      END DO
      RETURN
      END

ext: for

max_stars_repo_name: pedrobcst/Xerus

max_issues_repo_name: pedrobcst/Xerus

max_forks_repo_name: pedrobcst/Xerus


text:
MODULE hartree_module

  use hartree_variables
  use hartree_sol_module
  use hartree_sol_ffte_module
  use hartree_mol_module
 !use esm_hartree_module
  use hartree_ene_module

  implicit none

  PRIVATE
  PUBLIC :: calc_hartree, init_hartree

  integer :: SYStype=0
  integer :: Nspin
  integer :: Md
  integer :: ML0, ML1

CONTAINS

  SUBROUTINE init_hartree( Igrid, Nspin_in, Md_in, SYStype_in )
    implicit none
    integer,intent(IN) :: Igrid(2,0:3), Nspin_in, Md_in, SYStype_in

    call write_border( 0, " init_hartree(start)" )

    ML0     = Igrid(1,0)
    ML1     = Igrid(2,0)
    Nspin   = Nspin_in
    Md      = Md_in
    SYStype = SYStype_in

    allocate( Vh(ML0:ML1) )
    Vh=0.0d0

    select case( SYStype )
    case(1)
       call init_hartree_mol(Md)
    !case(2)
    !   call init_esm_hartree(Md)
    end select

    call write_border( 0, " init_hartree(end)" )

  END SUBROUTINE init_hartree

  SUBROUTINE calc_hartree(n1,n2,n3,rho)
    implicit none
    integer,intent(IN) :: n1,n2,n3
    real(8),intent(IN) :: rho(n1:n2,n3)
    real(8),allocatable :: trho(:)
    integer :: i,s

    call write_border( 1, " calc_hartree(start)" )

    select case(SYStype)
    case default

       call calc_hartree_sol(n1,n2,n3,rho)

    case(1)

       allocate( trho(n1:n2) )
!$OMP parallel do
       do i=n1,n2
          trho(i) = rho(i,1)
       end do
!$OMP end parallel do
       do s=2,n3
!$OMP parallel do
          do i=n1,n2
             trho(i) = trho(i) + rho(i,s)
          end do
!$OMP end parallel do
       end do
       call calc_hartree_mol(n1,n2,1,trho,Vh,E_hartree)
       call calc_hartree_ene( trho, Vh, E_hartree )
       deallocate( trho )

!    case(3)

!       call calc_esm_hartree(n1,n2,n3,rho,Vh,E_hartree)

    end select

    call write_border( 1, " calc_hartree(end)" )

  END SUBROUTINE calc_hartree

END MODULE hartree_module

max_stars_repo_name: j-iwata/RSDFT

max_issues_repo_name: j-iwata/RSDFT

max_forks_repo_name: j-iwata/RSDFT


text:
#include "macros.h"

module test_symmops
    use numbers
    use openmpi
    use io
    use parameters
    use fftw
    use symmops

    contains

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

    subroutine test_symmops_mirrorx(in_vfieldk, out_vfieldk)

        complex(dpc), intent(inout) :: in_vfieldk(:, :, :, :)
        complex(dpc), intent(out) :: out_vfieldk(:, :, :, :)
        complex(dpc) :: swap(ny_half,nz)

        integer(i4) :: ix

        out_vfieldk(:,:,:,1:3) = in_vfieldk(:,:,:,1:3)

        do ix = 1, nx / 2 ! ix = nx / 2 + 1 is zeroed

            if (ix == 1) then
                out_vfieldk(ix, :, :, 1) = -out_vfieldk(ix, :, :, 1)
                out_vfieldk(ix, :, :, 2:3) = out_vfieldk(ix, :, :, 2:3)

            else
                swap(:, :) = out_vfieldk(ix, :, :, 1)
                out_vfieldk(ix, :, :, 1) = -out_vfieldk(nx - ix + 2, :, :, 1)
                out_vfieldk(nx - ix + 2, :, :, 1) = -swap(:,:)

                swap(:, :) = out_vfieldk(ix, :, :, 2)
                out_vfieldk(ix, :, :, 2) = out_vfieldk(nx - ix + 2, :, :, 2)
                out_vfieldk(nx - ix + 2, :, :, 2) = swap(:,:)

                swap(:, :) = out_vfieldk(ix, :, :, 3)
                out_vfieldk(ix, :, :, 3) = out_vfieldk(nx - ix + 2, :, :, 3)
                out_vfieldk(nx - ix + 2, :, :, 3) = swap(:,:)

            end if

        end do

    end subroutine test_symmops_mirrorx

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

    subroutine test_symmops_mirrory(in_vfieldk, out_vfieldk)

        complex(dpc), intent(in)  :: in_vfieldk(:, :, :, :)
        complex(dpc), intent(out) :: out_vfieldk(:, :, :, :)

        _indices

        out_vfieldk(:, :, :, 1:3) = in_vfieldk(:, :, :, 1:3)

        do iy = 1, ny_half

            if (iy == 1) then
                ! w(0, kx, ky) -> -w(0, kx, ky)
                out_vfieldk(:, iy, :, 2) = -in_vfieldk(:, iy, :, 2)
                ! [u,v](0, kx, ky) -> [u,v](0, kx, ky)
                out_vfieldk(:, iy, :, (/1, 3/)) = in_vfieldk(:, iy, :, (/1, 3/))

            else

                do ix=1, nx; do iz=1,nz
                    if(iz == iz_max) cycle; if(ix_max /= -1 .and. ix == ix_max) cycle;
                    if (ix==1 .and. iz==1) then
                        ! Re w(kz, 0, 0) -> -Re w(kz, 0, 0)
                        out_vfieldk(ix,iy,iz, 2)%re = -in_vfieldk(ix,iy,iz, 2)%re
                        ! Re [u,v](kz, 0, 0) -> Re [u,v](kz, 0, 0)
                        out_vfieldk(ix,iy,iz, (/1, 3/))%re = in_vfieldk(ix,iy,iz, (/1, 3/))%re
                        ! Im w(kz, 0, 0) -> Im w(kz, 0, 0)
                        out_vfieldk(ix,iy,iz, 2)%im = in_vfieldk(ix,iy,iz, 2)%im
                        out_vfieldk(ix,iy,iz, (/1, 3/))%im = -in_vfieldk(ix,iy,iz, (/1, 3/))%im
                    else if (ix==1 .and. iz/=1) then
                        out_vfieldk(ix,iy,iz, 2)%re = -in_vfieldk(ix,iy,nz-iz+2, 2)%re
                        out_vfieldk(ix,iy,iz, (/1, 3/))%re = in_vfieldk(ix,iy,nz-iz+2, (/1, 3/))%re
                        out_vfieldk(ix,iy,iz, 2)%im = in_vfieldk(ix,iy,nz-iz+2, 2)%im
                        out_vfieldk(ix,iy,iz, (/1, 3/))%im = -in_vfieldk(ix,iy,nz-iz+2, (/1, 3/))%im
                    else if (ix/=1 .and. iz==1) then
                        out_vfieldk(ix,iy,iz, 2)%re = -in_vfieldk(nx-ix+2,iy,iz, 2)%re
                        out_vfieldk(ix,iy,iz, (/1, 3/))%re = in_vfieldk(nx-ix+2,iy,iz, (/1, 3/))%re
                        out_vfieldk(ix,iy,iz, 2)%im = in_vfieldk(nx-ix+2,iy,iz, 2)%im
                        out_vfieldk(ix,iy,iz, (/1, 3/))%im = -in_vfieldk(nx-ix+2,iy,iz, (/1, 3/))%im
                    else

                        ! Real parts
                        out_vfieldk(ix,iy,iz, 2)%re = -in_vfieldk(nx-ix+2,iy,nz-iz+2, 2)%re
                        out_vfieldk(ix,iy,iz, (/1, 3/))%re = in_vfieldk(nx-ix+2,iy,nz-iz+2, (/1, 3/))%re
                        ! Imaginary parts
                        out_vfieldk(ix,iy,iz, 2)%im = in_vfieldk(nx-ix+2,iy,nz-iz+2, 2)%im
                        out_vfieldk(ix,iy,iz, (/1, 3/))%im = -in_vfieldk(nx-ix+2,iy,nz-iz+2, (/1, 3/))%im

                    end if

                end do; end do

            end if

        end do

    end subroutine test_symmops_mirrory

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

    subroutine test_symmops_mirrorz(in_vfieldxx, out_vfieldxx)
        real(dp), intent(inout)  :: in_vfieldxx(:, :, :, :)
        real(dp), intent(out) :: out_vfieldxx(:, :, :, :)

        integer(i4) :: izz
        real(dp) :: swap(nyy, nxx)

        out_vfieldxx(:,:,:,1:3) = in_vfieldxx(:,:,:,1:3)

        ! Reflect in x
        do izz = 1, nzz / 2 + 1

            if (izz == 1 .or. (mod(nzz, 2) == 0 .and. izz == nzz / 2 + 1)) then

                ! sigma_x u(x) = - u(- x)
                out_vfieldxx(:, izz, :, 3) = -out_vfieldxx(:, izz, :, 3)

            else

                ! sigma_x u(x) = - u(- x)
                swap(:, :) = out_vfieldxx(:, izz, :, 3)
                out_vfieldxx(:, izz, :, 3) = - out_vfieldxx(:, nzz - (izz - 2), :, 3)
                out_vfieldxx(:, nzz - (izz - 2), :, 3) = -swap(:, :)

                swap(:, :) = out_vfieldxx(:, izz, :, 1)
                out_vfieldxx(:, izz, :, 1) = out_vfieldxx(:, nzz - (izz - 2), :, 1)
                out_vfieldxx(:, nzz - (izz - 2), :, 1) = swap(:, :)

                ! sigma_x [v,w](x) = [v,w](- x)
                swap(:, :) = out_vfieldxx(:, izz, :, 2)
                out_vfieldxx(:, izz, :, 2) = out_vfieldxx(:, nzz - (izz - 2), :, 2)
                out_vfieldxx(:, nzz - (izz - 2), :, 2) = swap(:, :)

            end if

        end do

    end subroutine test_symmops_mirrorz

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

    subroutine test_symmops_halfshiftx(in_vfieldxx, out_vfieldxx)

        real(dp), intent(inout) :: in_vfieldxx(:, :, :, :)
        real(dp), intent(out) :: out_vfieldxx(:, :, :, :)

        integer(i4) :: n
        real(dp) :: swap(nyy, nzz_perproc, nxx/2)

        if (mod(nxx, 2) /= 0) then
            write(out,*) "test_symmops_halfshiftx: can't work with odd nxx."
            flush(out)
            error stop
        end if

        out_vfieldxx(:,:,:,1:3) = in_vfieldxx(:,:,:,1:3)

        ! Shift in y-direction by Lx/2:
        do n=1,3
            swap(:, :, :) = out_vfieldxx(:, :, nxx/2+1:nxx, n)
            out_vfieldxx(:, :, nxx/2+1:nxx, n) = out_vfieldxx(:, :, 1:nxx/2,n)
            out_vfieldxx(:,:,1:nxx/2,n) = swap(:, :, :)
        end do

    end subroutine test_symmops_halfshiftx

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

    subroutine test_symmops_halfshifty(in_vfieldk, out_vfieldk)

        complex(dpc), intent(inout) :: in_vfieldk(:, :, :, :)
        complex(dpc), intent(out) :: out_vfieldk(:, :, :, :)

        integer(i4) :: iy

        out_vfieldk(:,:,:,1:3) = in_vfieldk(:,:,:,1:3)

        do iy = 1, ny_half

            if (mod(qy(iy), 2) /= 0) then

                out_vfieldk(:, iy, :, 1:3) = -out_vfieldk(:, iy, :, 1:3)

            end if

        end do

    end subroutine test_symmops_halfshifty

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

    subroutine test_symmops_halfshiftz(in_vfieldxx, out_vfieldxx)

        real(dp), intent(inout) :: in_vfieldxx(:, :, :, :)
        real(dp), intent(out) :: out_vfieldxx(:, :, :, :)

        integer(i4) :: n
        real(dp) :: swap(nyy, nzz/2, nxx)

        if (mod(nzz, 2) /= 0) then
            write(out,*) "test_symmops_halfshiftz: can't work with odd nzz."
            flush(out)
            error stop
        end if

        out_vfieldxx(:,:,:,1:3) = in_vfieldxx(:,:,:,1:3)

        do n=1,3
            swap(:, :, :) = out_vfieldxx(:, nzz/2+1:nzz, :, n)
            out_vfieldxx(:, nzz/2+1:nzz, :, n) = out_vfieldxx(:, 1:nzz/2, :,n)
            out_vfieldxx(:,1:nzz/2,:,n) = swap(:, :, :)
        end do

    end subroutine test_symmops_halfshiftz

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

end module test_symmops

max_stars_repo_name: gokhanyalniz/dnsbox

max_issues_repo_name: gokhanyalniz/dnsbox

max_forks_repo_name: gokhanyalniz/dnsbox


text:
C Copyright(C) 2009 Sandia Corporation. Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of Sandia Corporation nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C---5---10---15---20---25---30---35---40---45---50---55---60---65---70--
C $Log: grcolt.f,v $
C Revision 1.4  2009/03/25 12:36:44  gdsjaar
C Add copyright and license notice to all files.
C Permission to assert copyright has been granted; blot is now open source, BSD
C
C Revision 1.3  1998/07/07 14:07:30  gdsjaar
C Added variable to SAVE
C
C Modified to pass in a variable instead of a computed value since the
C argument is changed in the routine.
C
C Initialize variable
C
C Revision 1.2  1998/06/12 15:53:12  gdsjaar
C 1. Problem with TIMES array. Blot accesses a dummy timestep even if
C there were no timesteps on the database. Array wasn't allocated, so
C writing off into never-never land.
C
C 2. Inconsistency among some common blocks. Some places weren't using
C the include but had the definition hardwired in. Removed those.
C
C 3. Added 'EXTERNAL BLKDAT' to all routines that used data values set
C in BLKDAT
C
C 4. Cleanup of some A vs. IA argument passing.
C
C Revision 1.1  1994/04/07 20:02:13  gdsjaar
C Initial checkin of ACCESS/graphics/blotII2
C
c Revision 1.6  1993/08/24  16:45:35  gdsjaar
c Added entries to common block for additional user-specified colormap
c selection
c
c Revision 1.5  1993/08/16  21:23:05  gdsjaar
c Added inverse color map to default map, added other color map files to
c Imakefile, upped version number.
c
c Revision 1.4  1993/08/16  19:42:41  gdsjaar
c Added new spectrum options: gray, rainbow, hot, terrain, zebra
c
c Revision 1.3  1993/03/01  16:57:21  gdsjaar
c jwswegl - added rainbow spectrum (closer to visible spectrum) specify
c with RAINBOW ncol.  Added CGLOBAL to toggle between global and local
c contour labelling.
c
c Revision 1.2  1990/12/14  08:51:31  gdsjaar
c Added RCS Id and Log to all files
c
C=======================================================================
      SUBROUTINE GRCOLT
C=======================================================================

C   --*** GRCOLT *** (GRPLIB) Set alternate color table (PLT)
C   --   Written by Amy Gilkey - revised 04/11/88
C   --
C   --GRCOLT sets the alternate color table (colors 8..) to a specified
C   --color table map.  The following maps are defined:
C   --       spectrum colors blue to red
C   --       rainbow colors violet to red
C   --
C   --Common Variables:
C   --   Uses DEVOK, ICURDV, NUMCOL, MAPALT of /GRPCOM/
C   --   Sets MAPUSE of /GRPCOM/

C   --Routines Called:
C   --   PLTCOL - (PLTLIB) Set color table color
C   --   PLTIQC - (PLTLIB) Get color table color

      EXTERNAL BLKDAT

      PARAMETER (KCOLOR=1)
      PARAMETER (KCOLIN=6, KCOSYM=44)

      include 'grpcom.blk'

C  Flag for rainbow spectrum
      include 'icrnbw.blk'

      REAL SRED(0:4), SGREEN(0:4), SBLUE(0:4)
      SAVE SRED, SGREEN, SBLUE
C      --SRED, SGREEN, SBLUE - color ratios for RGB settings; spectrum is
C      --   divided in 4 parts

      REAL RRED(32:255), RGREEN(32:255), RBLUE(32:255)
      SAVE RRED, RGREEN, RBLUE
C  RRED, RGREEN, RBLUE - color ratios for RGB settings; rainbow is
C  from TOOPLOT color table; numbering 32-255 has been retained
C  in order to use original coding to generate table.
C  The original routineS used 0-255 for color definition values.
C  These are scaled to the range 0.-1. here.

      INTEGER LSTALT(2), LSTNUM(2)
      SAVE LSTALT, LSTNUM, SATLST, IRNBWL
C      --LSTALT - the color type last set for the device
C      --LSTNUM - the number of colors last set for the device

      DATA SRED   / 0.20, 0.50, 0.80, 0.85, 1.00 /
      DATA SGREEN / 0.60, 0.70, 0.80, 0.60, 0.10 /
      DATA SBLUE  / 1.00, 0.50, 0.25, 0.10, 0.10 /

C  INITIALIZE ALL RAINBOW COLORS TO ZERO - COLOR TABLE HAS NOT BEEN CREATED
      DATA RRED   / 224*0. /
      DATA RGREEN / 224*0. /
      DATA RBLUE  / 224*0. /

      DATA LSTALT / 0, 0 /
      DATA LSTNUM / 0, 0 /
      DATA SATLST / 0.0  /
      DATA IRNBWL / -1 /

      IF (MAPALT(ICURDV) .LE. 0) THEN
         CONTINUE

      ELSE IF ((MAPALT(ICURDV) .NE. LSTALT(ICURDV))
     &   .OR. (NUMCOL(MAPALT(ICURDV),ICURDV) .NE. LSTNUM(ICURDV))
     &   .OR.  IRNBWL.NE.IRAINB  .OR.  SATUR .NE. SATLST) THEN

        IF (MAPALT(ICURDV) .EQ. 1) THEN

C         --Set up a spectrum of colors in colors 8+

          IF(IRAINB.EQ.0 .AND. ISPEC .EQ. 0)THEN
C  Blue-brown-red spectrum (DEFAULT)

            IF (NUMCOL(1,ICURDV) .EQ. 1) THEN
               CALL PLTCOL (8+0, 0.0, 0.0, 1.0)

            ELSE IF (NUMCOL(1,ICURDV) .EQ. 2) THEN
              if (isinv .eq. 0) then
                CALL PLTCOL (8+0, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+1, 1.0, 0.0, 0.0)
              else
                CALL PLTCOL (8+1, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+0, 1.0, 0.0, 0.0)
              end if
            ELSE IF (NUMCOL(1,ICURDV) .EQ. 3) THEN
              if (isinv .eq. 0) then
                CALL PLTCOL (8+0, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+1, 0.0, 1.0, 0.0)
                CALL PLTCOL (8+2, 1.0, 0.0, 0.0)
              else
                CALL PLTCOL (8+2, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+1, 0.0, 1.0, 0.0)
                CALL PLTCOL (8+0, 1.0, 0.0, 0.0)
              end if
            ELSE IF (NUMCOL(1,ICURDV) .EQ. 5) THEN
              if (isinv .eq. 0) then
                CALL PLTCOL (8+0, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+1, 0.0, 1.0, 1.0)
                CALL PLTCOL (8+2, 0.0, 1.0, 0.0)
                CALL PLTCOL (8+3, 1.0, 1.0, 0.0)
                CALL PLTCOL (8+4, 1.0, 0.0, 0.0)
              else
                CALL PLTCOL (8+4, 0.0, 0.0, 1.0)
                CALL PLTCOL (8+3, 0.0, 1.0, 1.0)
                CALL PLTCOL (8+2, 0.0, 1.0, 0.0)
                CALL PLTCOL (8+1, 1.0, 1.0, 0.0)
                CALL PLTCOL (8+0, 1.0, 0.0, 0.0)
              end if
            ELSE
              NEWCOL = NUMCOL(1,ICURDV) - 1
              DO 10 I = 0, NEWCOL
                FRAC = FLOAT(I) / FLOAT(NEWCOL)
                ISEG = INT (FRAC * 4)
                REM = FRAC * 4 - ISEG
                XRED   = SRED(ISEG)
     &            - REM * (SRED(ISEG) - SRED(ISEG+1))
                XGREEN = SGREEN(ISEG)
     &            - REM * (SGREEN(ISEG) - SGREEN(ISEG+1))
                XBLUE  = SBLUE(ISEG)
     &            - REM * (SBLUE(ISEG) - SBLUE(ISEG+1))
                if (isinv .eq. 0) then
                  CALL PLTCOL (8+I, XRED, XGREEN, XBLUE)
                else
                  CALL PLTCOL (8+NEWCOL-I, XRED, XGREEN, XBLUE)
                end if
 10           CONTINUE
            END IF

          ELSE IF(IRAINB.EQ.0 .AND. ISPEC .GE. 1)THEN
            NEWCOL = NUMCOL(1,ICURDV) - 1
            call textur (SATUR, NUMCOL(1,ICURDV), ISPEC, ISINV,
     *        RMULT, GMULT, BMULT)
            SATLST = SATUR
          ELSE
C  Rainbow spectrum
           IF(RRED(32).EQ.0.)THEN

C  Color table has not been created. Generate it

C     Define colors 32-56 to be a linear variation from red to orange
C     Red    = 255,0,0    (R,G,B)
C     Orange = 255,168,0  (R,G,B)
C
             XIPCOL=168.0/24.0
             DO 50 I=32,56
              RRED(I)=1.
              RGREEN(I)=(I-32)*XIPCOL/255.
              RBLUE(I)=0.
   50        CONTINUE
C
C     Define colors 57-106 to be a linear variation from orange to yello
C     Orange = 255,168,0  (R,G,B)
C     Yellow = 255,255,0  (R,G,B)
C
             XIPCOL=87.0/50.0
             DO 60 I=57,106
              RRED(I)=1.
              RGREEN(I)=(168.0+(I-56)*XIPCOL)/255.
              RBLUE(I)=0.
   60        CONTINUE
C
C     Define colors 107-166 to be a linear variation from yellow to gree
C     Yellow = 255,255,0  (R,G,B)
C     Green  = 0,255,0    (R,G,B)
C
             XIPCOL=255.0/60.0
             DO 70 I=107,166
              RRED(I)=(255.0-(I-106)*XIPCOL)/255.
              RGREEN(I)=1.
              RBLUE(I)=0.
   70        CONTINUE
C
C     Define colors 167-210 to be a linear variation from green to blue
C     Green = 0,255,0  (R,G,B)
C     Blue  = 0,0,255  (R,G,B)
C
             XIPCOL=255.0/44.0
             DO 80 I=167,210
              RRED(I)=0.
              RGREEN(I)=(255.0-(I-166)*XIPCOL)/255.
              RBLUE(I)=(I-166)*XIPCOL/255.
   80        CONTINUE
C
C    Define colors 211-255 to be a linear variation from blue to violet
C    Blue   = 0,0,255    (R,G,B)
C    Purple = 180,0,180  (R,G,B)
C
             XICOLB = 75.0/45.0
             XICOLR = 180.0/45.0
             DO 90 I=211,255
              RRED(I)=(I-210)*XICOLR/255.
              RGREEN(I)=0.
              RBLUE(I)=(255.0-(I-210)*XICOLB)/255.
   90        CONTINUE

            ENDIF

            IF (NUMCOL(1,ICURDV) .EQ. 1) THEN
               CALL PLTCOL (8+0, 0.7059, 0.0, 0.7059)

            ELSE
               NEWCOL = NUMCOL(1,ICURDV) - 1
               DO 100 I = 0, NEWCOL
C  Interpolate on color number, not color values.
C  For a spectrum with less than 224 colors, choose
C  equally-spaced color numbers from the range 255-32
                  FRAC = FLOAT(I) / FLOAT(NEWCOL)
                  NC=NINT(255.-FRAC*223.)
                  CALL PLTCOL (8+I, RRED(NC), RGREEN(NC), RBLUE(NC))
  100          CONTINUE
            END IF

          ENDIF

         END IF

C      --Change old alternate colors to black

         IF (LSTALT(ICURDV) .GT. 0) THEN
            DO 110 I = NEWCOL+1, LSTNUM(ICURDV)-1
               CALL PLTCOL (8+I, 0.0, 0.0, 0.0)
  110       CONTINUE
         END IF
         CALL PLTFLU

         LSTALT(ICURDV) = MAPALT(ICURDV)
         LSTNUM(ICURDV) = NUMCOL(LSTALT(ICURDV),ICURDV)
      END IF

      MAPUSE(ICURDV) = MAPALT(ICURDV)

      IRNBWL=IRAINB

      RETURN
      END

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


text:
! This program will numerically compute the integral of
!                   4/(1+x*x)
! from 0 to 1.  The value of this integral is pi -- which
! is great since it gives us an easy way to check the answer.

! This version of the program uses a divide and concquer algorithm
! and recurrsion.

! History: C code written by Tim Mattson, 10/2013.
!          Adapted to Fortran code by Helen He, 09/2017.
!          Updated to Fortran90 code by Helen He, 11/2020.

module data_mod
   integer, parameter :: num_steps = 1024*1024*1024
   integer, parameter :: MIN_BLK = 1024*256

   contains
      real*8 recursive function pi_comp(Nstart, Nfinish, step) result(sum)
         implicit none

         integer, intent(in) :: Nstart, Nfinish
         real*8 :: x, sum1, sum2, step
         integer :: i, iblk

         sum = 0.0

         if (Nfinish - Nstart < MIN_BLK) then
            do i = Nstart,  Nfinish - 1
               x = (i + 0.5) * step
              sum = sum + 4.0 / (1.0 + x * x)
            enddo
         else
            iblk = Nfinish - Nstart
            sum1 = pi_comp(Nstart, Nfinish - iblk/2, step)
            sum2 = pi_comp(Nfinish - iblk/2, Nfinish, step)
            sum = sum1 + sum2
         endif

      end function

end module data_mod

program main
   use omp_lib
   use data_mod
   implicit none

   integer :: i
   real*8 :: pi, sum, step
   real*8 :: init_time, final_time

   init_time = OMP_GET_WTIME()

   step = 1.0 / num_steps
   sum = pi_comp(0, num_steps, step)
   pi = step * sum

   final_time = OMP_GET_WTIME() - init_time
   write(*,100) num_steps, pi, final_time
100    FORMAT(' With ', i14,' steps, pi = ', f15.8,' in ', f8.3,' secs')

end program main

max_stars_repo_name: zafar-hussain/OmpCommonCore

max_issues_repo_name: zafar-hussain/OmpCommonCore

max_forks_repo_name: zafar-hussain/OmpCommonCore


text:
program P1041
    implicit none
    integer(8) :: size
    integer(8) :: top, bottom, front, back, left, right
    integer(8) :: min_point, min_edge, min_face
    read *, size
    read *, top, right, front, back, left, bottom
    min_face = min(top, bottom, front, back, left, right)
    min_edge = min(top + front, top + back, top + left, top + right, &
        bottom + front, bottom + back, bottom + left, bottom + right, &
        front + left, front + right, &
        back + left, back + right)
    min_point = min(top + front + left, top + front + right, &
        top + back + left, top + back + right, &
        bottom + front + left, bottom + front + right, &
        bottom + back + left, bottom + back + right)
    if (size == 1) then
        write (*, '(I0)') top + bottom + front + back + left + right &
            - max(top, bottom, front, back, left, right)
    else
        write (*, '(I0)') min_point * 4 &
            + min_edge * 4 + min_edge * (size - 2) * 8 &
            + min_face * (size - 2) * 4 + min_face * (size - 2) * (size - 2) * 5
    end if
end program P1041

max_stars_repo_name: daily-boj/kiwiyou

max_issues_repo_name: daily-boj/kiwiyou

max_forks_repo_name: daily-boj/kiwiyou


!{ dg-do run }
!{ dg-options "-fno-range-check" }
!{ dg-add-options ieee }
!{ dg-skip-if "NaN not supported" { spu-*-* } { "*" } { "" } }
! PR19310 and PR19904, allow disabling range check during compile.
! Contributed by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
program main
  character(len=80) str
  real, parameter :: zero=0, nan=0/zero
  complex :: z = (-0.1,-2.2)/(0.0,0.0)
  complex :: z2 = (0.1,1)/0
  complex :: z3 = (1e35, -2e3)/1.234e-37
  complex :: z4 = (1e-35, -2e-35)/1234e34
  real :: a
  a = exp(1000.0)
  b = 1/exp(1000.0)

  write(str,*) a
  if (trim(adjustl(str)) .ne. 'Infinity') call abort

  if (b .ne. 0.) call abort

  write(str,*) -1.0/b
  if (trim(adjustl(str)) .ne. '-Infinity') call abort

  write(str,*) b/0.0
  if (trim(adjustl(str)) .ne. 'NaN') call abort

  write(str,*) 0.0/0.0
  if (trim(adjustl(str)) .ne. 'NaN') call abort

  write(str,*) 1.0/(-0.)
  if (trim(adjustl(str)) .ne. '-Infinity') call abort

  write(str,*) -2.0/0.
  if (trim(adjustl(str)) .ne. '-Infinity') call abort

  write(str,*) 3.0/0.
  if (trim(adjustl(str)) .ne. 'Infinity') call abort

  write(str,*)  nan
  if (trim(adjustl(str)) .ne. 'NaN') call abort

  write(str,*) z
  if (trim(adjustl(str)) .ne. '(NaN,NaN)') call abort

  write(str,*) z2
  if (trim(adjustl(str)) .ne. '(NaN,NaN)') call abort

  write(str,*) z3
  if (trim(adjustl(str)) .ne. '(Inf,-Inf)') call abort

  write(str,*) z4
  if (trim(adjustl(str)) .ne. '(0.00000000,-0.00000000)') call abort
end program main


text:
	SUBROUTINE GD_CPF ( parmin, parmout, iret )
C************************************************************************
C* GD_CPF                                                               *
C*                                                                      *
C* This subroutine checks if a file containing a latitude/longitude 	*
C*	pair(s) was input.     						*
C*                                                                      *
C* GD_CPF  ( PARMIN, PARMOUT, IRET )                                    *
C*                                                                      *
C* Input parameters:                                                    *
C*      PARMIN		CHAR*		GPOINT or CXSTNS parameter	*
C*                                                                      *
C* Output parameters:                                                   *
C*	PARMOUT		CHAR*		latitude/longitude pair(s)	*
C*      IRET            INTEGER         Return code                     *
C*                                        0 = normal return             *
C*					 -6 = open/read error		*
C**                                                                     *
C* Log:                                                                 *
C* T. Piper/SAIC	06/04	Created                                 *
C************************************************************************
	CHARACTER*(*) 	parmin, parmout
	CHARACTER	clat*8, clon*10, endp1*24, endp2*28
	REAL		xlat(2), xlon(2)
C------------------------------------------------------------------------
	iret = 0
C
C*	If a ';' is included, it is not a file name.
C*	This will eliminate grid point pairs and lat/lon pairs.
C
	isemic = INDEX ( parmin, ';' )
	idot = INDEX ( parmin, '.' )
	IF ( isemic .gt. 0 ) THEN
	    parmout = parmin
	    return
	ELSE IF ( idot .gt. 0 ) THEN
C
C*	This is a file because the only other valid inputs that are NOT
C*	grid points or lat/lon points are station numeric or character
C*	identifiers, which should not have a '.' in them.
C
	    ndec = 4
	    CALL ST_NULL ( parmin, parmin, lenin, ier )
	    CALL CTB_RDCPF ( parmin, npnts, xlat, xlon, iret )
	    IF ( iret .eq. 0 ) THEN
	        CALL ST_RLCH ( xlat(1), ndec, clat, ier )
	        CALL ST_RLCH ( xlon(1), ndec, clon, ier )
		endp1 = clat // ' ; ' // clon
		IF ( npnts .eq. 1 ) THEN
		    endp2 = ' '
		ELSE
		    CALL ST_RLCH ( xlat(2), ndec, clat, ier )
                    CALL ST_RLCH ( xlon(2), ndec, clon, ier )
		    endp2 = ' > ' // clat // ' ; ' // clon
		END IF
		parmout = endp1 // endp2
	    ELSE
		iret = -6
		parmout = ' '
	    END IF
	END IF
C
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
! check F2.x edit descriptors
! PR 14746
      CHARACTER*15 LINE
      RCON21 = 9.
      RCON22 = .9
      WRITE(LINE,'(F2.0,1H,,F2.1)')RCON21,RCON22
      READ(LINE,'(F2.0,1X,F2.1)')XRCON21,XRCON22
      IF (RCON21.NE.XRCON21) CALL ABORT
      IF (RCON22.NE.XRCON22) CALL ABORT
      END

max_issues_repo_name: vidkidz/crossbridge

max_forks_repo_name: vidkidz/crossbridge


text:
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!   SOLVER : BICG (d'après TEMPLATES)           11.02.97
!
!   Utilise ILU0 & ILUTP
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

PROGRAM TEST_BICG

    implicit none

    integer :: N, NELEM, iwk
    parameter(N = 100, NELEM = 5000, iwk= 10000)

    double precision :: A(NELEM)
    integer :: IA(N+1), JA(NELEM)

    double precision :: ALU(iwk)
    integer :: JLU(iwk), JU(N)   ! JU(N+1) ??? BUG????????

    double precision :: B(N),X(N),xref(N)
    integer :: iw(2*N)

    double precision :: z(N),z2(N),r(N),r2(N),p(N),p2(N),q(N),q2(N)
    integer :: iperm(2*N)

    integer :: ierr, it_max, iflag, lfil, mbloc

    double precision :: epsilon, droptol, permtol

    integer :: i

    CHARACTER(100) :: sysfile

    ! read cmd line args
    IF(COMMAND_ARGUMENT_COUNT().NE.1)THEN
        WRITE(*,*)'ERROR, 1 COMMAND-LINE ARGUMENTS REQUIRED, STOPPING'
        !STOP  ! TODO
    ENDIF
    CALL GET_COMMAND_ARGUMENT(1, sysfile)
    write(*,*) 'sysfile = ', sysfile

!c      DIMENSION A(NELEM), IA(N+1), JA(NELEM),
!c     #          ALU(iwk),JLU(iwk), JU(N),
!c     #          B(N),X(N),iw(2*N),
!c     #          z(N),z2(N),r(N),r2(N),p(N),p2(N),q(N),q2(N),
!c     #          iperm(2*N),xref(N)

    ierr=0

    ! -- Chargement de la matrice A et du vecteur b ---------
    CALL loadmat(A, IA, JA, b, xref, ierr)

    ! -- Paramètres du SYMMLQ -------------------------------
    epsilon = 1.0D-8
    it_max  = 800
    iflag   = 2
    ierr    = 0

    ! -- Paramètres du préconditionneur ---------------------
    droptol = 0.0
    lfil    = 40
    permtol = 0.1
    mbloc   = N

    IF(iflag.EQ.1) THEN
        CALL ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr)
    ENDIF
    IF(iflag.EQ.2) THEN
        CALL ilutp(n, a, ja, ia, lfil, droptol, permtol, mbloc, alu,     &
                    jlu, ju, iwk, r, iw, iperm, ierr)
    ENDIF
    WRITE(*,*)'ierr=', ierr, '    <ENTER>'
    read(*,*)

    ! -- Appel de la sous-routine BICG -------------------

    CALL BICG(N, x, b, A, IA, JA, ALU, JLU, JU, epsilon,      &
              it_max, z, z2, r, r2, p, p2, q, q2, IFLAG, ierr)

    ! -- Permutation de la solution (si pivotage employé) --

    IF(IFLAG.EQ.2) THEN
        DO i=1,N
        r(i)=x(iperm(n+i))
    ENDDO
        DO i=1,N
        x(i)=r(i)
    ENDDO
    ENDIF

    ! -- Sauvegarde du résultat vers MATLAB ----------------

    OPEN (UNIT = 1, FILE = 's_gmres.m', STATUS='UNKNOWN')
    DO i = 1, N
        WRITE(1,*)'x(',i,')=',x(i),';'
    ENDDO
    CLOSE (UNIT = 1)

    ! -- Visualisation de la solution ----------------------

    WRITE(*,*)
    WRITE(*,*)' <ENTER> pour voir la solution'
    READ(*,*)
    CALL VectAff2(N, x, xref)

END PROGRAM TEST_BICG

max_stars_repo_name: rboman/progs

max_issues_repo_name: rboman/progs

max_forks_repo_name: rboman/progs


text:
Pomegranate Place is a hidden collection of 11 cottages and 2 houses located at 521 7th Street.  They fill a oneacre lot behind the visible house, and are accessible via a winding cement sidewalk which runs from the end of the driveway on 7th Street all the way through to 8th Street.

These cottages were all relocated to this land from F and 1st Streets, where they were a part of a little enclave called Asbill Court.  All of the cottages there were moved to make way for an office building, which is now a part of the Hallmark Inn

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
cdis    Forecast Systems Laboratory
cdis    NOAA/OAR/ERL/FSL
cdis    325 Broadway
cdis    Boulder, CO     80303
cdis
cdis    Forecast Research Division
cdis    Local Analysis and Prediction Branch
cdis    LAPS
cdis
cdis    This software and its documentation are in the public domain and
cdis    are furnished "as is."  The United States government, its
cdis    instrumentalities, officers, employees, and agents make no
cdis    warranty, express or implied, as to the usefulness of the software
cdis    and documentation for any purpose.  They assume no responsibility
cdis    (1) for the use of the software and documentation; or (2) to provide
cdis     technical support to users.
cdis
cdis    Permission to use, copy, modify, and distribute this software is
cdis    hereby granted, provided that the entire disclaimer notice appears
cdis    in all copies.  All modifications to this software must be clearly
cdis    documented, and are solely the responsibility of the agent making
cdis    the modifications.  If significant modifications or enhancements
cdis    are made to this software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis
cdis
cdis
cdis
cdis
cdis

        subroutine wait_for_data(c_filespec,i4time_desired   !  Inputs
     1               ,i4_check_interval,i4_total_wait        !  Inputs
     1               ,i4_thresh_age       ! Only loop through the waiting
                                          ! if most recent data is younger
                                          ! than this threshold age (Input)
     1               ,istatus)            ! Output

!       Steve Albers FSL 1995, 2001

!       Note all times are in seconds

        character*255 c_filespec      ! Wild card specifying the full path
!       and filenames. NOTE: If there are very many files in the directory,
!       you will need to use a directory name only, the ls command can't
!       handle it otherwise. The wildcard is especially useful if there
!       is more than one type of file in the directory.

!       The c_filespec string should not have a particular file time within it.
!       Valid examples of c_filespec are 'directory/*ext' and 'directory'.

        logical l_waited

        character*8 c8_project

        call get_c8_project(c8_project,istatus)
        if(istatus .eq. 0)return

        l_waited = .false.

        i4time_start_wait = i4time_now_gg()

        write(6,*)' Wait for data:'
     1           ,' i4_check_interval,i4_total_wait,i4_thresh_age'
        write(6,*)  i4_check_interval,i4_total_wait,i4_thresh_age

 10     call get_latest_file_time(c_filespec,i4time_nearest)

        i4_data_age = i4time_desired-i4time_nearest

        write(6,*)' Wait for data:'
     1           ,' i4time_desired,i4time_nearest,i4_data_age'
        write(6,*)  i4time_desired,i4time_nearest,i4_data_age

        if(i4time_nearest .eq. 0)then
            istatus = 0
            return
        endif

        if(i4_data_age .gt. 0 .and. i4_data_age .le. i4_thresh_age)then
            i4time_current = i4time_now_gg()
            i4_wait_sofar = i4time_current - i4time_start_wait

            if(i4_wait_sofar .lt. i4_total_wait)then
                write(6,*)' Searching for more data, sleep '
     1                   ,i4_check_interval
                r4_check_interval = float(i4_check_interval)
                call snooze_gg(r4_check_interval,istatus)
                if(istatus .ne. 1)then
                    write(6,*)' ERROR in wait_for_data from snooze'
                    return
                endif

                l_waited = .true.

                goto 10

            endif

        endif

!       Assess the latest data age
        if(i4_data_age .eq. 0)then
            write(6,*)' Wait for data: Found the data'
            istatus = 1
        elseif(i4_data_age .gt. i4_thresh_age)then
            write(6,*)' Latest data too old, not waiting for new data'
            istatus = 0
        elseif(i4_data_age .lt. 0)then
            write(6,*)' Wait for data: '
     1               ,'Found the data (later than requested time)'
            istatus = 1
        else
            write(6,*)' Wait for data: Never did find the data'
            istatus = 0
        endif

        if(istatus .eq. 1 .and. c8_project(1:3) .eq. 'WFO')then
            if(l_waited)then
                r_additional_wait = 60.
            else
                r_additional_wait = 50.
            endif

            write(6,*)' Doing wait to allow full file update: '
     1               ,r_additional_wait
            call snooze_gg(r_additional_wait,istatus)
            if(istatus .ne. 1)then
                write(6,*)' ERROR in wait_for_data returned from snooze'
                return
            endif
        endif

        return
        end

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
C Copyright(C) 2009 Sandia Corporation. Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of Sandia Corporation nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C $Log: msmemy.f,v $
C Revision 1.3  2009/03/25 12:36:46  gdsjaar
C Add copyright and license notice to all files.
C Permission to assert copyright has been granted; blot is now open source, BSD
C
C Revision 1.2  2005/09/27 13:34:53  gdsjaar
C Fixed some issues with memory access out of bounds
C
C Revision 1.1  1994/04/07 20:05:48  gdsjaar
C Initial checkin of ACCESS/graphics/blotII2
C
c Revision 1.2  1990/12/14  08:53:58  gdsjaar
c Added RCS Id and Log to all files
c
C=======================================================================
      SUBROUTINE MSMEMY (A, ANYDEF, ANYUND,
     &  DOIXF, DON2B, DOELED, DOELEU, DODEAD, DONPS, DOESS,
     &  NSURFS, KN2ELB, KDN2B, KIF2EL,
     &  KXN, KYN, KZN, KHZ, KVT, KPD, KDHZ, KDVT, KDPD,
     &  KXF, KYF, KZF, KDXF, KDYF, KDZF, KHIDEN, KHIDEF, KIXFAC,
     &  KSNPS, KSESS)
C=======================================================================

C   --*** MSMEMY *** (MESH) Reserve memory for mesh plot
C   --   Written by Amy Gilkey - revised 07/27/88
C   --
C   --MSMEMY reserves or finds the memory needed to plot a mesh.
C   --
C   --This routine reserves and finds the following dynamic memory arrays:
C   --   IN2ELB - the element block for each node;
C   --      <0 if not in any selected element block
C   --      =0 if in more than one selected element block
C   --   IDN2B - the element block for each dead node; dead if >= 0
C   --   HZ, VT, PD - the undeformed nodal coordinates
C   --      (rotated for 3D, PD for 3D only)
C   --   DHZ, DVT, DPD - the deformed nodal coordinates
C   --      (rotated for 3D, DPD for 3D only)
C   --   XF, YF, ZF - the undeformed face center coordinates
C   --      (rotated for 3D, ZF for 3D only)
C   --   DXF, DYF, DZF - the deformed face center coordinates
C   --      (rotated for 3D, DZF for 3D only)
C   --   HIDENP(i) - true iff node i is hidden (3D only)
C   --   HIDEF(i) - true iff face i is hidden (3D only)
C   --   IXFAC - the indices of the ordered faces (3D only)
C   --   IX2NP - the node number for each mesh index (MASTER process only)
C   --   SCRNPS - scratch array for node sets
C   --   SCRESS - scratch array for side sets
C   --
C   --This routine uses MDFIND to find the following dynamic memory arrays:
C   --   IF2EL - the element number of each face
C   --   XN, YN, ZN - IN - the nodal coordinates (ZN for 3D only)
C   --
C   --Parameters:
C   --   A - IN - the dynamic memory base array
C   --   ANYDEF - IN - true iff any deformed mesh is to be plotted
C   --   ANYUND - IN - true iff any undeformed mesh is to be plotted
C   --   DOIXF - IN - true iff the IXFAC array is needed
C   --   DON2B - IN - true iff the IN2ELB array is needed
C   --   DOELED - IN - true iff the deformed element quarilateral centers
C   --      are needed
C   --   DOELEU - IN - true iff the undeformed element quarilateral centers
C   --      are needed
C   --   DODEAD - IN - true iff dead nodes are needed
C   --   DONPS - IN - true iff node set information is needed
C   --   DOESS - IN - true iff side set information is needed
C   --   NSURFS - IN - the number of surface faces
C   --   KN2ELB - OUT - the index of IN2ELB
C   --   KDN2B - OUT - the index of IDN2B
C   --   KIF2EL - OUT - the index of IF2EL
C   --   KXN, KYN, KZN - OUT - the indices of XN, YN, ZN
C   --   KHZ, KVT, KPD - OUT - the indices of HZ, VT, PD
C   --   KDHZ, KDVT, KDPD - OUT - the indices of DHZ, DVT, DPD
C   --   KXF, KYF, KZF - OUT - the indices of XF, YF, ZF
C   --   KDXF, KDYF, KDZF - OUT - the indices of DXF, DYF, DZF
C   --   KHIDEN - OUT - the index of HIDENP
C   --   KHIDEF - OUT - the index of HIDEF
C   --   KIXFAC - OUT - the index of IXFAC
C   --   KSNPS - OUT - the index of SCRNPS
C   --   KSESS - OUT - the index of SCRESS
C   --
C   --Common Variables:
C   --   Uses NDIM of /DBNUMS/
C   --   Uses IS3DIM, NUMNPF of /D3NUMS/
C   --   Uses DEFPRO, DEFOK of /DEFORM/
C   --   Sets NPSIZ of /SIZES/

      include 'dbnumgq.blk'
      include 'dbnums.blk'
      include 'd3nums.blk'
      include 'deform.blk'
      include 'sizes.blk'

      DIMENSION A(*)
      LOGICAL ANYDEF, ANYUND
      LOGICAL DOIXF, DON2B, DOELED, DOELEU, DODEAD, DONPS, DOESS

      LOGICAL FIRST
      SAVE FIRST
C      --FIRST - true iff first time through routine

      DATA FIRST / .TRUE. /

      IF (FIRST) THEN
        FIRST = .FALSE.

C      --Reserve memory (most will be expanded when needed)

        CALL MDRSRV ('IN2ELB', KN2ELB, 0)
        CALL MDFIND ('IF2EL', KIF2EL, IDUM)

        CALL MDFIND ('XN', KXN, IDUM)
        CALL MDFIND ('YN', KYN, IDUM)
        IF (IS3DIM) THEN
          CALL MDFIND ('ZN', KZN, IDUM)
        ELSE
          KZN = 1
        END IF

C      --Set size of deformed coordinate arrays for hidden line algorithm
        NPSIZ = NUMNPF
        IF (IS3DIM) NPSIZ = (13 * NUMNPF) / 10

        IF (IS3DIM) THEN
C         --QNPICK uses MDFIND to find HZ, VT, PD
          CALL MDRSRV ('HZ', KHZ, 0)
          CALL MDRSRV ('VT', KVT, 0)
          CALL MDRSRV ('PD', KPD, 0)
        ELSE
          KHZ = KXN
          KVT = KYN
          KPD = KZN
        END IF

        IF (DEFOK) THEN
C         --QNPICK uses MDFIND to find DHZ, DVT, DPD
          CALL MDRSRV ('DHZ', KDHZ, 0)
          CALL MDRSRV ('DVT', KDVT, 0)
          IF (IS3DIM) THEN
            CALL MDRSRV ('DPD', KDPD, 0)
          ELSE
            KDPD = 1
          END IF
        ELSE
          KDHZ = 1
          KDVT = 1
          KDPD = 1
        END IF

        CALL MDRSRV ('XF', KXF, 0)
        CALL MDRSRV ('YF', KYF, 0)
        IF (IS3DIM) THEN
          CALL MDRSRV ('ZF', KZF, 0)
        ELSE
          KZF = 1
        END IF

        IF (DEFOK) THEN
          CALL MDRSRV ('DXF', KDXF, 0)
          CALL MDRSRV ('DYF', KDYF, 0)
          IF (IS3DIM) THEN
            CALL MDRSRV ('DZF', KDZF, 0)
          ELSE
            KDZF = 1
          END IF
        END IF

C      --QNPICK uses MDFIND to find HIDENP
        IF (IS3DIM) THEN
          CALL MDRSRV ('HIDENP', KHIDEN, NUMNPF)
        ELSE
          KHIDEN = 1
        END IF
        IF (IS3DIM) THEN
          CALL MDRSRV ('HIDEF', KHIDEF, NSURFS)
        ELSE
          KHIDEF = 1
        END IF

C      --Reserve the mesh index to node number index
        CALL MDRSRV ('IX2NP', KIX2NP, 0)
      END IF

C   --Find memory

      CALL MDFIND ('IN2ELB', KN2ELB, IDUM)
      CALL MDFIND ('IF2EL', KIF2EL, IDUM)

      IF (DODEAD) THEN
        CALL MDRSRV ('IDN2B', KDN2B, 0)
      ELSE
        KDN2B = 1
      END IF

      CALL MDFIND ('XN', KXN, IDUM)
      CALL MDFIND ('YN', KYN, IDUM)
      IF (IS3DIM) THEN
        CALL MDFIND ('ZN', KZN, IDUM)
      ELSE
        KZN = 1
      END IF

      IF (IS3DIM) THEN
        CALL MDFIND ('HZ', KHZ, IDUM)
        CALL MDFIND ('VT', KVT, IDUM)
        CALL MDFIND ('PD', KPD, IDUM)
      ELSE
        KHZ = KXN
        KVT = KYN
        KPD = KZN
      END IF

      IF (DEFOK .AND. DEFPRO) THEN
        CALL MDFIND ('DHZ', KDHZ, IDUM)
        CALL MDFIND ('DVT', KDVT, IDUM)
        IF (IS3DIM) THEN
          CALL MDFIND ('DPD', KDPD, IDUM)
        ELSE
          KDPD = 1
        END IF
      ELSE
        KDHZ = 1
        KDVT = 1
        KDPD = 1
      END IF

      CALL MDFIND ('XF', KXF, IDUM)
      CALL MDFIND ('YF', KYF, IDUM)
      IF (IS3DIM) THEN
        CALL MDFIND ('ZF', KZF, IDUM)
      ELSE
        KZF = 1
      END IF

      IF (DEFOK .AND. DEFPRO) THEN
        CALL MDFIND ('DXF', KDXF, IDUM)
        CALL MDFIND ('DYF', KDYF, IDUM)
        IF (IS3DIM) THEN
          CALL MDFIND ('DZF', KDZF, IDUM)
        ELSE
          KDZF = 1
        END IF
      ELSE
        KDXF = 1
        KDYF = 1
        KDZF = 1
      END IF

      IF (IS3DIM) THEN
        CALL MDFIND ('HIDENP', KHIDEN, IDUM)
      ELSE
        KHIDEN = 1
      END IF
      KIXFAC = 1
      IF (IS3DIM) THEN
        CALL MDFIND ('HIDEF', KHIDEF, IDUM)
        IF (DOIXF) CALL MDRSRV ('IXFAC', KIXFAC, NSURFS)
      ELSE
        KHIDEF = 1
      END IF

      IF (DONPS) THEN
        CALL MDRSRV ('SCRNPS', KSNPS, NUMNPS)
      ELSE
        KSNPS = 1
      END IF
      IF (DOESS) THEN
        CALL MDRSRV ('SCRESS', KSESS, NUMESS)
      ELSE
        KSESS = 1
      END IF

      CALL MDSTAT (NERR, MEM)
      IF (NERR .GT. 0) GOTO 100

 100  CONTINUE
      RETURN
      END


text:
*DECK SCGS
      SUBROUTINE SCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
     +   ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1,
     +   V2, RWORK, IWORK)
C***BEGIN PROLOGUE  SCGS
C***PURPOSE  Preconditioned BiConjugate Gradient Squared Ax=b Solver.
C            Routine to solve a Non-Symmetric linear system  Ax = b
C            using the Preconditioned BiConjugate Gradient Squared
C            method.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  D2A4, D2B4
C***TYPE      SINGLE PRECISION (SCGS-S, DCGS-D)
C***KEYWORDS  BICONJUGATE GRADIENT, ITERATIVE PRECONDITION,
C             NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE
C***AUTHOR  Greenbaum, Anne, (Courant Institute)
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-60
C             Livermore, CA 94550 (510) 423-3141
C             seager@llnl.gov
C***DESCRIPTION
C
C *Usage:
C      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C      INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED)
C      REAL    B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N)
C      REAL    Q(N), U(N), V1(N), V2(N), RWORK(USER DEFINED)
C      EXTERNAL MATVEC, MSOLVE
C
C      CALL SCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC,
C     $     MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT,
C     $     R, R0, P, Q, U, V1, V2, RWORK, IWORK)
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Real B(N).
C         Right-hand side vector.
C X      :INOUT    Real X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :IN       Integer IA(NELT).
C JA     :IN       Integer JA(NELT).
C A      :IN       Real A(NELT).
C         These arrays contain the matrix data structure for A.
C         It could take any form.  See "Description", below,
C         for more details.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all non-zero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C MATVEC :EXT      External.
C         Name of a routine which  performs the matrix vector multiply
C         operation  Y = A*X  given A and X.  The  name of  the MATVEC
C         routine must  be declared external  in the  calling program.
C         The calling sequence of MATVEC is:
C             CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A*X upon
C         return,  X is an input  vector.  NELT, IA,  JA,  A and  ISYM
C         define the SLAP matrix data structure: see Description,below.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system MZ = R  for Z
C         given R with the preconditioning matrix M (M is supplied via
C         RWORK  and IWORK arrays).   The name  of  the MSOLVE routine
C         must be declared  external  in the  calling   program.   The
C         calling sequence of MSOLVE is:
C             CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C         Where N is the number of unknowns, R is  the right-hand side
C         vector, and Z is the solution upon return.  NELT,  IA, JA, A
C         and  ISYM define the SLAP  matrix  data structure: see
C         Description, below.  RWORK is a  real array that can be used
C         to  pass   necessary  preconditioning     information and/or
C         workspace to MSOLVE.  IWORK is an integer work array for the
C         same purpose as RWORK.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         This routine must calculate the residual from R = A*X - B.
C         This is unnatural and hence expensive for this type of iter-
C         ative method.  ITOL=2 is *STRONGLY* recommended.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv time a vector is the pre-
C         conditioning step.  This is the *NATURAL* stopping for this
C         iterative method and is *STRONGLY* recommended.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C             COMMON /SSLBLK/ SOLN( )
C         If ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.
C TOL    :INOUT    Real.
C         Convergence criterion, as described above.  (Reset if IERR=4.)
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Real.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient space allocated for WORK or IWORK.
C           IERR = 2 => Method failed to converge in ITMAX steps.
C           IERR = 3 => Error in user input.
C                       Check input values of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500*R1MACH(3).  Iteration proceeded.
C           IERR = 5 => Breakdown of the method detected.
C                       (r0,r) approximately 0.
C           IERR = 6 => Stagnation of the method detected.
C                       (r0,v) approximately 0.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C R      :WORK     Real R(N).
C R0     :WORK     Real R0(N).
C P      :WORK     Real P(N).
C Q      :WORK     Real Q(N).
C U      :WORK     Real U(N).
C V1     :WORK     Real V1(N).
C V2     :WORK     Real V2(N).
C         Real arrays used for workspace.
C RWORK  :WORK     Real RWORK(USER DEFINED).
C         Real array that can be used for workspace in MSOLVE.
C IWORK  :WORK     Integer IWORK(USER DEFINED).
C         Integer array that can be used for workspace in MSOLVE.
C
C *Description
C       This routine does  not care  what matrix data   structure is
C       used for  A and M.  It simply   calls  the MATVEC and MSOLVE
C       routines, with  the arguments as  described above.  The user
C       could write any type of structure and the appropriate MATVEC
C       and MSOLVE routines.  It is assumed  that A is stored in the
C       IA, JA, A  arrays in some fashion and  that M (or INV(M)) is
C       stored  in  IWORK  and  RWORK   in  some fashion.   The SLAP
C       routines SSDBCG and SSLUCS are examples of this procedure.
C
C       Two  examples  of  matrix  data structures  are the: 1) SLAP
C       Triad  format and 2) SLAP Column format.
C
C       =================== S L A P Triad format ===================
C
C       In  this   format only the  non-zeros are  stored.  They may
C       appear  in *ANY* order.   The user  supplies three arrays of
C       length NELT, where  NELT  is the number  of non-zeros in the
C       matrix:  (IA(NELT), JA(NELT),  A(NELT)).  For each  non-zero
C       the  user puts   the row  and  column index   of that matrix
C       element in the IA and JA arrays.  The  value of the non-zero
C       matrix  element is  placed in  the corresponding location of
C       the A  array.  This is  an extremely easy data  structure to
C       generate.  On  the other hand it  is  not too  efficient  on
C       vector  computers   for the  iterative  solution  of  linear
C       systems.  Hence, SLAP  changes this input  data structure to
C       the SLAP   Column  format for the  iteration (but   does not
C       change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix      SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C
C       In  this format   the non-zeros are    stored counting  down
C       columns (except  for the diagonal  entry, which must  appear
C       first in each "column") and are  stored in the real array A.
C       In other words,  for  each column    in the matrix   put the
C       diagonal  entry  in A.   Then   put  in the  other  non-zero
C       elements going   down the  column (except  the  diagonal) in
C       order.  The IA array holds the row index  for each non-zero.
C       The JA array holds the offsets into the IA, A arrays for the
C       beginning   of   each  column.      That is,   IA(JA(ICOL)),
C       A(JA(ICOL)) points to the beginning of the ICOL-th column in
C       IA and  A.  IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1)  points to the
C       end of the ICOL-th column.  Note that we always have JA(N+1)
C       = NELT+1, where N is the number of columns in the matrix and
C       NELT is the number of non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C           5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Cautions:
C     This routine will attempt to write to the Fortran logical output
C     unit IUNIT, if IUNIT .ne. 0.  Thus, the user must make sure that
C     this logical unit is attached to a file or terminal before calling
C     this routine with a non-zero value for IUNIT.  This routine does
C     not check for the validity of a non-zero IUNIT unit number.
C
C***SEE ALSO  SSDCGS, SSLUCS
C***REFERENCES  1. P. Sonneveld, CGS, a fast Lanczos-type solver
C                  for nonsymmetric linear systems, Delft University
C                  of Technology Report 84-16, Department of Mathe-
C                  matics and Informatics, Delft, The Netherlands.
C               2. E. F. Kaasschieter, The solution of non-symmetric
C                  linear systems by biconjugate gradients or conjugate
C                  gradients squared,  Delft University of Technology
C                  Report 86-21, Department of Mathematics and Informa-
C                  tics, Delft, The Netherlands.
C               3. Mark K. Seager, A SLAP for the Masses, in
C                  G. F. Carey, Ed., Parallel Supercomputing: Methods,
C                  Algorithms and Applications, Wiley, 1989, pp.135-155.
C***ROUTINES CALLED  ISSCGS, R1MACH, SAXPY, SDOT
C***REVISION HISTORY  (YYMMDD)
C   871119  DATE WRITTEN
C   881213  Previous REVISION DATE
C   890915  Made changes requested at July 1989 CML Meeting.  (MKS)
C   890921  Removed TeX from comments.  (FNF)
C   890922  Numerous changes to prologue to make closer to SLATEC
C           standard.  (FNF)
C   890929  Numerous changes to reduce SP/DP differences.  (FNF)
C   891004  Added new reference.
C   910411  Prologue converted to Version 4.0 format.  (BAB)
C   910502  Removed MATVEC and MSOLVE from ROUTINES CALLED list.  (FNF)
C   920407  COMMON BLOCK renamed SSLBLK.  (WRB)
C   920511  Added complete declaration section.  (WRB)
C   920929  Corrected format of references.  (FNF)
C   921019  Changed 500.0 to 500 to reduce SP/DP differences.  (FNF)
C   921113  Corrected C***CATEGORY line.  (FNF)
C***END PROLOGUE  SCGS
C     .. Scalar Arguments ..
      REAL ERR, TOL
      INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT
C     .. Array Arguments ..
      REAL A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), U(N),
     +     V1(N), V2(N), X(N)
      INTEGER IA(NELT), IWORK(*), JA(NELT)
C     .. Subroutine Arguments ..
      EXTERNAL MATVEC, MSOLVE
C     .. Local Scalars ..
      REAL AK, AKM, BK, BNRM, FUZZ, RHON, RHONM1, SIGMA, SOLNRM, TOLMIN
      INTEGER I, K
C     .. External Functions ..
      REAL R1MACH, SDOT
      INTEGER ISSCGS
      EXTERNAL R1MACH, SDOT, ISSCGS
C     .. External Subroutines ..
      EXTERNAL SAXPY
C     .. Intrinsic Functions ..
      INTRINSIC ABS
C***FIRST EXECUTABLE STATEMENT  SCGS
C
C         Check some of the input data.
C
      ITER = 0
      IERR = 0
      IF( N.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      TOLMIN = 500*R1MACH(3)
      IF( TOL.LT.TOLMIN ) THEN
         TOL = TOLMIN
         IERR = 4
      ENDIF
C
C         Calculate initial residual and pseudo-residual, and check
C         stopping criterion.
      CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM)
      DO 10 I = 1, N
         V1(I)  = R(I) - B(I)
 10   CONTINUE
      CALL MSOLVE(N, V1, R, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C
      IF( ISSCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q,
     $     U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 )
     $     GO TO 200
      IF( IERR.NE.0 ) RETURN
C
C         Set initial values.
C
      FUZZ = R1MACH(3)**2
      DO 20 I = 1, N
         R0(I) = R(I)
 20   CONTINUE
      RHONM1 = 1
C
C         ***** ITERATION LOOP *****
C
      DO 100 K=1,ITMAX
         ITER = K
C
C         Calculate coefficient BK and direction vectors U, V and P.
         RHON = SDOT(N, R0, 1, R, 1)
         IF( ABS(RHONM1).LT.FUZZ ) GOTO 998
         BK = RHON/RHONM1
         IF( ITER.EQ.1 ) THEN
            DO 30 I = 1, N
               U(I) = R(I)
               P(I) = R(I)
 30         CONTINUE
         ELSE
            DO 40 I = 1, N
               U(I) = R(I) + BK*Q(I)
               V1(I) = Q(I) + BK*P(I)
 40         CONTINUE
            DO 50 I = 1, N
               P(I) = U(I) + BK*V1(I)
 50         CONTINUE
         ENDIF
C
C         Calculate coefficient AK, new iterate X, Q
         CALL MATVEC(N, P, V2, NELT, IA, JA, A, ISYM)
         CALL MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK)
         SIGMA = SDOT(N, R0, 1, V1, 1)
         IF( ABS(SIGMA).LT.FUZZ ) GOTO 999
         AK = RHON/SIGMA
         AKM = -AK
         DO 60 I = 1, N
            Q(I) = U(I) + AKM*V1(I)
 60      CONTINUE
         DO 70 I = 1, N
            V1(I) = U(I) + Q(I)
 70      CONTINUE
C         X = X - ak*V1.
         CALL SAXPY( N, AKM, V1, 1, X, 1 )
C                     -1
C         R = R - ak*M  *A*V1
         CALL MATVEC(N, V1, V2, NELT, IA, JA, A, ISYM)
         CALL MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK)
         CALL SAXPY( N, AKM, V1, 1, R, 1 )
C
C         check stopping criterion.
         IF( ISSCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
     $        ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q,
     $        U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 )
     $        GO TO 200
C
C         Update RHO.
         RHONM1 = RHON
 100  CONTINUE
C
C         *****   end of loop  *****
C         Stopping criterion not satisfied.
      ITER = ITMAX + 1
      IERR = 2
 200  RETURN
C
C         Breakdown of method detected.
 998  IERR = 5
      RETURN
C
C         Stagnation of method detected.
 999  IERR = 6
      RETURN
C------------- LAST LINE OF SCGS FOLLOWS ----------------------------
      END


text:
!# define PP_SPLIT_FORM 1

module two_point_flux_mod

use constants_mod

private

public :: xflux, yflux, zflux

contains

pure function xflux(uL,uR) result(fstar)

    use equations_const_mod
    use setup_config_mod, only: kappa
    use setup_config_mod, only: mu0
    use equations_share_mod, only: GLM_ch

    real(dp), intent(in)    :: uL(N_VARS)
    real(dp), intent(in)    :: uR(N_VARS)
    real(dp)                :: fstar(N_VARS)

    real(dp), parameter :: kappaM1  = kappa - 1.0_dp
    real(dp), parameter :: skappaM1 = 1.0_dp/(kappa - 1.0_dp)
    real(dp), parameter :: smu_0    = 1.0_dp/mu0

    real(dp) :: betaLN,beta_R,beta_L
    real(dp) :: rhoLN,B2_L,B2_R,v2_L,v2_R
    real(dp) :: pTilde,p_L,p_R
    real(dp) :: v_L(3),v_R(3)
    real(dp) :: BAvg(3),vAvg(3)
    real(dp) :: v1_B2Avg
    real(dp) :: vB_Avg
    real(dp) :: psiAvg

    associate(&
        rho_L   => UL(1),   rho_R   => UR(1), &
        rhoV_L  => UL(2:4), rhoV_R  => UR(2:4), &
        E_L     => UL(5)-0.5_dp*smu_0*UL(9)**2, E_R => UR(5)-0.5_dp*smu_0*UR(9)**2, &
        psi_L   => UL(9), psi_R => UR(9), &
        B_L     => UL(6:8), B_R => UR(6:8))

    !! Get the inverse density, velocity, and pressure on left and right.
    v_L = rhoV_L(:)/rho_L
    v_R = rhoV_R(:)/rho_R

    v2_L = SUM(v_L(:)*v_L(:))
    v2_R = SUM(v_R(:)*v_R(:))
    B2_L = SUM(B_L(:)*B_L(:))
    B2_R = SUM(B_R(:)*B_R(:))

    p_L    = kappaM1*(E_L - 0.5_dp*(rho_L*v2_L+smu_0*B2_L))
    p_R    = kappaM1*(E_R - 0.5_dp*(rho_R*v2_R+smu_0*B2_R))
    beta_L = 0.5_dp*rho_L/p_L
    beta_R = 0.5_dp*rho_R/P_R

    !! Get the averages for the numerical flux.
    rhoLN      = ln_mean(rho_L, rho_R)
    betaLN     = ln_mean(beta_L,beta_R)
    vAvg       = 0.5_dp * (v_L + v_R)
    BAvg       = 0.5_dp * (B_L + B_R)
    v1_B2Avg   = 0.5_dp * (v_L(1)*B2_L + v_R(1)*B2_R)
    vB_Avg     = 0.5_dp * (SUM(V_L(:)*B_L(:)) + SUM(V_R(:)*B_R(:)))
    pTilde     = 0.5_dp * ((rho_L+rho_R)/(beta_L+beta_R)+smu_0*0.5_dp*(B2_L+B2_R))
    psiAvg     = 0.5_dp * (psi_L+psi_R)

    !! Entropy conserving and kinetic energy conserving flux.
    Fstar(1) = rhoLN*vAvg(1)
    Fstar(2) = Fstar(1)*vAvg(1) - smu_0*BAvg(1)*BAvg(1) + pTilde
    Fstar(3) = Fstar(1)*vAvg(2) - smu_0*BAvg(1)*BAvg(2)
    Fstar(4) = Fstar(1)*vAvg(3) - smu_0*BAvg(1)*BAvg(3)
    Fstar(7) = vAvg(1)*Bavg(2) - BAvg(1)*vAvg(2)
    Fstar(8) = vAvg(1)*Bavg(3) - BAvg(1)*vAvg(3)
    Fstar(6) = GLM_ch*psiAvg
    Fstar(9) = GLM_ch*BAvg(1)

    !! Total energy flux.
    Fstar(5) = Fstar(1)*0.5_dp*(skappaM1/betaLN - 0.5_dp*(v2_L+v2_R))  &
               + SUM(vAvg(:)*Fstar(2:4)) &
               + smu_0*(SUM(BAvg(:)*Fstar(6:8)) &
                       - 0.5_dp*v1_B2Avg + BAvg(1)*vB_Avg &
                       + Fstar(9)*psiAvg-GLM_ch*0.5_dp*(psi_L*B_L(1)+psi_R*B_R(1)))
    end associate

end function

pure function yflux(u) result(f)

    real(dp), intent(in)    :: u(N_VARS)
    real(dp)                :: f(N_VARS)
    real(dp)                :: ru(N_VARS), rf(N_VARS) !! rotated

    !! rotating to x-direction
    ru(DENS_VAR) = u(DENS_VAR)

    ru(MOMX_VAR) = u(MOMY_VAR)
    ru(MOMY_VAR) = u(MOMZ_VAR)
    ru(MOMZ_VAR) = u(MOMX_VAR)

    ru(ENER_VAR) = u(ENER_VAR)

    ru(MAGX_VAR) = u(MAGY_VAR)
    ru(MAGY_VAR) = u(MAGZ_VAR)
    ru(MAGZ_VAR) = u(MAGX_VAR)

    ru(GLMP_VAR) = u(GLMP_VAR)

    rf = xflux(ru)

    !! rotating back
    f(DENS_VAR) = rf(DENS_VAR)

    f(MOMX_VAR) = rf(MOMZ_VAR)
    f(MOMY_VAR) = rf(MOMX_VAR)
    f(MOMZ_VAR) = rf(MOMY_VAR)

    f(ENER_VAR) = rf(ENER_VAR)

    f(MAGX_VAR) = rf(MAGZ_VAR)
    f(MAGY_VAR) = rf(MAGX_VAR)
    f(MAGZ_VAR) = rf(MAGY_VAR)

    f(GLMP_VAR) = rf(GLMP_VAR)

end function

pure function zflux(u) result(f)

    real(dp), intent(in)    :: u(N_VARS)
    real(dp)                :: f(N_VARS)
    real(dp)                :: ru(N_VARS), rf(N_VARS) !! rotated

    !! rotating to x-direction
    ru(DENS_VAR) = u(DENS_VAR)

    ru(MOMX_VAR) = u(MOMZ_VAR)
    ru(MOMY_VAR) = u(MOMX_VAR)
    ru(MOMZ_VAR) = u(MOMY_VAR)

    ru(ENER_VAR) = u(ENER_VAR)

    ru(MAGX_VAR) = u(MAGZ_VAR)
    ru(MAGY_VAR) = u(MAGX_VAR)
    ru(MAGZ_VAR) = u(MAGY_VAR)

    ru(GLMP_VAR) = u(GLMP_VAR)

    rf = xflux(ru)

    !! rotating back
    f(DENS_VAR) = rf(DENS_VAR)

    f(MOMX_VAR) = rf(MOMY_VAR)
    f(MOMY_VAR) = rf(MOMZ_VAR)
    f(MOMZ_VAR) = rf(MOMX_VAR)

    f(ENER_VAR) = rf(ENER_VAR)

    f(MAGX_VAR) = rf(MAGY_VAR)
    f(MAGY_VAR) = rf(MAGZ_VAR)
    f(MAGZ_VAR) = rf(MAGX_VAR)

    f(GLMP_VAR) = rf(GLMP_VAR)

end function

pure elemental function logmean(a,b) result(r)

    real(dp), intent(in)    :: a,b
    real(dp)                :: x,u,r

    real(dp),parameter  :: eps = 1e-4_dp
    real(dp), parameter :: c1 = 1.0_dp/6.0_dp
    real(dp), parameter :: c2 = 2.0_dp/45.0_dp
    real(dp), parameter :: c3 = 22.0_dp/945.0_dp

    x = a/b

    if (abs(a-b) < eps) then
        u  = (x*(x-2.0_dp)+1.0_dp)/(x*(x+2.0_dp)+1.0_dp)
        r = (a+b)*(0.5_dp - u*(c1 - u*(c2 - c3*u)))
    else
        r = (a-b)/log(x)
    endif

end function

!==================================================================================================================================
!> Computes the logarithmic mean: (aR-aL)/(LOG(aR)-LOG(aL)) = (aR-aL)/LOG(aR/aL)
!> Problem: if aL~= aR, then 0/0, but should tend to --> 0.5*(aR+aL)
!>
!> introduce xi=aR/aL and f=(aR-aL)/(aR+aL) = (xi-1)/(xi+1)
!> => xi=(1+f)/(1-f)
!> => Log(xi) = log(1+f)-log(1-f), and for smaRl f (f^2<1.0E-02) :
!>
!>    Log(xi) ~=     (f - 1/2 f^2 + 1/3 f^3 - 1/4 f^4 + 1/5 f^5 - 1/6 f^6 + 1/7 f^7)
!>                  +(f + 1/2 f^2 + 1/3 f^3 + 1/4 f^4 + 1/5 f^5 + 1/6 f^6 + 1/7 f^7)
!>             = 2*f*(1           + 1/3 f^2           + 1/5 f^4           + 1/7 f^6)
!>  (aR-aL)/Log(xi) = (aR+aL)*f/(2*f*(1 + 1/3 f^2 + 1/5 f^4 + 1/7 f^6)) = (aR+aL)/(2 + 2/3 f^2 + 2/5 f^4 + 2/7 f^6)
!>  (aR-aL)/Log(xi) = 0.5*(aR+aL)*(105/ (105+35 f^2+ 21 f^4 + 15 f^6)
!==================================================================================================================================
pure elemental function LN_MEAN(aL,aR)

    REAL(dp), INTENT(IN) :: aL  !< left value
    REAL(dp), INTENT(IN) :: aR  !< right value

    REAL(dp)            :: LN_MEAN  !< result

    REAL(dp)            :: Xi,u
    REAL(dp), PARAMETER :: eps = 1.0e-4_dp  ! tolerance for f^2, such that switch is smooth in double precision

    Xi = aR/aL
    u = (Xi*(Xi-2.0_dp)+1.0_dp)/(Xi*(Xi+2.0_dp)+1.0_dp) !u=f^2, f=(aR-aL)/(aR+aL)=(xi-1)/(xi+1)
    LN_MEAN = MERGE((aL+aR)*52.5_dp/(105_dp + u*(35_dp + u*(21_dp +u*15_dp))), & !u <eps (test true)
                  (aR-aL)/LOG(Xi)                                         , & !u>=eps (test false)
                  (u.LT.eps)                                              )   !test

end function

end module

max_stars_repo_name: jmark/nemo

max_issues_repo_name: jmark/nemo

max_forks_repo_name: jmark/nemo


text:
A small Convenience Stores convenience store contained within The Lexington apartments complex on Olive Drive, this Market has some amazing prices:

  $1 for a large coffee
  25¢ for a large cup of hot water (for tea or cocoa mix)
  99¢ for any size fountain drink
  99¢ for any size Icee
  Cheapest Kegs in Davis
  $1 samosas on occasion, homemade by the managers wife

They compete quite heavily with the University Shell Shell Gasoline station just down the street. The people who work here are usually very friendly and even learn the names of regulars.

As reported in the 20060413 California Aggie, they can now sell liquor.

20080510 18:45:10 nbsp This place is a hidden treasure trove of cheap booze.  Users/OscarSabino

20081115 10:54:42 nbsp Olive drive market is going to have special as follows: Mickeys 6pk bottle on 11/28/08, 12/12/08 and 12/26/08 from 5 pm to 7 pm only the cute girls will be handing out some extra bucks for special pricing please visit and find out. Users/sanyabajaj

20081115 10:56:30 nbsp they also have specials on handles of smirnoff, captain morgan and malibu. Users/sanyabajaj

20090405 23:29:28 nbsp Suresh the manger is the nicest business owner Ive ever met in Davis. Right now they have Three Olive vodka handles for 19.99, thats about $15.00 cheaper than MSRP! Get SOME!!!!! Users/msandsor
   Suresh is quite awesome, and one of the handful of business owners I really miss from Davis. Users/JabberWokky jw

20110217 06:42:07 nbsp This place has the nicest people, good prices on smokes, and downright amazing beer and liquor prices. Not to mention they have all the basic necessities a college student could hope for. As a resident of Olive Drive, this place is my lifeline Users/acoope

20111002 11:03:02 nbsp CHECK:THE DATE.  They are selling EXPIRED FOOD!  Got home to realize it was not just a week expired but more than 3 MONTHS!!!!!   Users/MickPetz

20120726 13:01:06 nbsp I used to live above this market, and I must say, its probably the best one in town. Perhaps in the world. And Suresh and all of his staff were always so lovely and kind. GO HERE. And purchase all of their alcohol!!  Users/momokoneko

20130424 19:12:16 nbsp I could not find samosa??? and no coffee ?? Keg in no cheaper in compare to other store Users/robertpaul


text:
      SUBROUTINE TISOSR	(nplot, IERROR)
C
C LATEST REVISION	 DECEMBER 1984
C
C PURPOSE		 TO PROVIDE A SIMPLE DEMONSTRATION OF
C			 ISOSRF	AND TO TEST ISOSRF ON A	SINGLE PROBLEM
C
C USAGE			 CALL TISOSR (IERROR)
C
C ARGUMENTS
C
C ON OUTPUT		 IERROR
C			   AN INTEGER VARIABLE
C			   = 0,	IF THE TEST WAS	SUCCESSFUL,
C			   = 1,	OTHERWISE
C
C I/O			 IF THE	TEST IS	SUCCESSFUL, THE	MESSAGE
C
C			   ISOSRF TEST SUCCESSFUL  . . . SEE PLOT TO
C			   VERIFY PERFORMANCE
C
C			 IS WRITTEN ON UNIT 6.
C			 IN ADDITION, TWO FRAMES CONTAINING THE	SAMPLE
C			 PLOTS ARE PRODUCED ON THE MACHINE GRAPHICS
C			 DEVICE.  IN ORDER TO DETERMINE	IF THE TEST
C			 WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE
C			 THESE PLOTS.
C
C PRECISION		 SINGLE
C
C REQUIRED LIBRARY	 ISOSRF	FROM ULIB LIBRARY
C FILES
C
C LANGUAGE		 STANDARD FORTRAN77
C
C HISTORY		 WRITTEN  BY MEMBERS OF	THE
C			 SCIENTIFIC COMPUTING DIVISION OF NCAR,
C			 BOULDER COLORADO
C
C ALGORITHM		 A FUNCTION OF THREE VARIABLES IS DEFINED, AND
C			 VALUES	OF THE FUNCTION	ON A THREE DIMENSIONAL
C			 RECTANGULAR GRID ARE STORED IN	AN ARRAY.  THIS
C			 SUBROUTINE CALLS EZISOS AND ISOSRF TO DRAW ISO-
C			 VALUED	SURFACE	PLOTS OF THE FUNCTION.
C
C PORTABILITY		 ANSI STANDARD
C
C
      SAVE
      DIMENSION	      T(21,31,19),SLAB(33,33),EYE(3)
C
C SPECIFY COORDINATES FOR PLOT TITLES.	ON AN ABSTRACT GRID WHERE
C THE INTEGER COORDINATES RANGE	FROM 1 TO 1024,	THE VALUES IX AND IY
C DEFINE THE CENTER OF THE TITLE STRING.
C
      REAL IX,IY
      DATA IX/.44/, IY/.95/
C
      DATA NU,NV,NW/21,31,19/
      DATA RBIG1,RBIG2,RSML1,RSML2/6.,6.,2.,2./
      DATA TISO/0./
      DATA MUVWP2/33/
      DATA IFLAG/-7/
C
C INITIALIZE ERROR PARAMETER
C
      IERROR = 1
C
C FILL THREE DIMENSIONAL ARRAY TO BE PLOTTED
C
      JCENT1 = FLOAT(NV)*.5-RBIG1*.5
      JCENT2 = FLOAT(NV)*.5+RBIG2*.5
      DO  30 I=1,NU
	 FIMID = I-NU/2
	 DO  20	J=1,NV
	    FJMID1 = J-JCENT1
	    FJMID2 = J-JCENT2
	    DO	10 K=1,NW
	       FKMID = K-NW/2
	       F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1))
	       F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1))
	       FIP1 = (1.-F1)*FIMID
	       FIP2 = (1.-F2)*FIMID
	       FJP1 = (1.-F1)*FJMID1
	       FJP2 = (1.-F2)*FJMID2
	       FKP1 = (1.-F1)*FKMID
	       FKP2 = (1.-F2)*FKMID
	       T(I,J,K)	= AMIN1(FIMID*FIMID+FJP1*FJP1+FKP1*FKP1-
     1			  RSML1*RSML1,
     2			    FKMID*FKMID+FIP2*FIP2+FJP2*FJP2-RSML2*RSML2)
   10	    CONTINUE
   20	 CONTINUE
   30 CONTINUE
C
C DEFINE EYE POSITION
C
      EYE(1) = 100.
      EYE(2) = 150.
      EYE(3) = 125.
C
C LABEL	THE PLOT TO BE DRAWN BY	EZISOS
C
      if (nplot .eq. 1) then
      CALL GSELNT(0)
      CALL WTSTR(IX,IY,'DEMONSTRATION PLOT FOR ENTRY EZISOS OF ISOSRF',
     1 2,0,0)
C
C TEST EZISOS
C
      CALL EZISOS (T,NU,NV,NW,EYE,SLAB,TISO)
      endif
C
C LABEL	THE PLOT TO BE DRAWN BY	ISOSRF
C
      if (nplot .eq. 2) then
      CALL GSELNT(0)
      CALL WTSTR(IX,IY,'DEMONSTRATION PLOT FOR ENTRY ISOSRF OF ISOSRF',
     1 2,0,0)
C
C TEST ISOSRF WITH SUBARRAY OF T
C
      MU=NU/2
      MV=NV/2
      MW=NW/2
      MUVWP2=MAX0(MU,MV,MW)+2
      CALL ISOSRF(T(MU,MV,MW),NU,MU,NV,MV,MW,EYE,MUVWP2,SLAB,TISO,IFLAG)
      endif
c     CALL FRAME
C
      IERROR = 0
c     WRITE (6,1001)
      RETURN
C
c1001 FORMAT ('	    ISOSRF TEST	SUCCESSFUL',24X,
c    1	      'SEE PLOT	TO VERIFY PERFORMANCE')
C
      END

max_stars_repo_name: ysBach/irafdocgen

max_issues_repo_name: kirxkirx/iraf

max_forks_repo_name: kirxkirx/iraf


text:
module type_mesh_motion_wrapper
    use mod_kinds, only: ik
    use type_mesh_motion,          only: mesh_motion_t
    implicit none

    type    :: mesh_motion_wrapper_t

        class(mesh_motion_t),  allocatable :: mm

    end type mesh_motion_wrapper_t

end module type_mesh_motion_wrapper

max_stars_repo_name: nwukie/ChiDG

max_issues_repo_name: nwukie/ChiDG

max_forks_repo_name: nwukie/ChiDG


text:
Don Saylor is a member of the Yolo County Board of Supervisors, representing the second district.  He was a member of the City Council who was first elected in 2004, and who was reelected in 2008 City Council Election June 2008.  His first term was from March 2004 to June 2008. During his second term (20082010) he served two years as Mayor Pro Tem (20082010) and then would have served two years as the Mayor (20102012) (see below). In June 2010 Don was pronounced Mayor and served in this position until January 2011, where he took his office as Supervisor.

Prior to being elected as a councilmember, Saylor served on the Davis Joint Unified School District Davis school board from 19952003. He was president of the board in 1998 and 2000.

Check out Don Saylors http://www.yolocounty.org/Index.aspx?page2072 Biography on the Yolo County website.

 Yolo County Board of Supervisors

On 20091002, Don held http://www.donsaylor.org/events/YoloFestInvite.pdf Yolo Fest, a kickoff fund raiser for his bid to run for Yolo County supervisor in 2010. Don was elected County Supervisor in the 2010 City Council Election 2010 Election and so will only serve 2 1/2 years out of 4 years of his City Council seat.

This has caused some controversy about when he should resign and how his successor is to be chosen.  If he were to resign early, a new election could be held for him at the same time as the regular 2010 November election. However, he has said that he owes it to the voters who elected him to stay until January 2011, when he will resign to become County Supervisor. This leaves the remaining Council with two choices to replace him: 1) hold a special election, at an estimated cost of $300,000 when the city budget is already strained or 2) select a successor, which some (e.g., Sue Greenwald) see as undemocratic. Letters to the editor of the The Davis Enterprise suggest that many are unhappy with Saylors decision not to resign early, although of course there are some who support the decision. This may have something to do with Saylor receiving only 3442 out of 5343 votes , or 64% (http://www.davisvanguard.org/index.php?optioncom_content&viewarticle&id3491:vanguardanalysissaylorskatesinunopposedbutwithrelativelylowpercentageofsupport&catid57:citycouncil&Itemid80 as estimated by the Vanguard), even though he was running unopposed.

 Positions on controversial issues
  Halema Buzayan case: He was quoted in an http://www.davisenterprise.com/archive_pdfs/2008/20080525/pdfs/C5.pdf opinion column in the Davis Enterprise as saying Every specific (police misconduct) case that has been raised has been shown to be without merit. ... We have yet to see any of the flagrant abuses that have been described. In fact, every time we look they are not there.
  Measure J debate: Saylor has said he supports the concept behind Measure J but thinks it should undergo a thorough review before being reestablished.

 Endorsements
 Given
Don http://media.www.californiaaggie.com/media/storage/paper981/news/2008/02/01/CampusNews/Councilmembers.Endorse.Primary.Candidates3182296.shtml endorsed Hillary Clinton for the February 2008 Primary Election.
 Received
  2008 Davis Professional Firefighters Association
 Literature


text: array A = [-1] U32

ext: fpp

max_stars_repo_name: kevin-f-ortega/fpp

max_issues_repo_name: kevin-f-ortega/fpp

max_forks_repo_name: kevin-f-ortega/fpp


text: #redirect Activities and Recreation Center


text:
c****************************************************************

	subroutine convert_sch_to_xyz(ptm,r_schv,r_xyzv,i_type)

c****************************************************************
c**
c**	FILE NAME: convert_sch_to_xyz.for
c**
c**     DATE WRITTEN:1/15/93
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION: This routine applies the affine matrix
c**     provided to convert the sch coordinates xyz WGS-84 coordintes or
c**     the inverse transformation.
c**
c**     ROUTINES CALLED:latlon,matvec
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:

c	structure /pegtrans/          !transformation parameters
c	   real*8 r_mat(3,3)
c	   real*8 r_matinv(3,3)
c	   real*8 r_ov(3)
c	   real*8 r_radcur
c	end structure
c	record /pegtrans/ ptm

	type pegtrans
          sequence
	  real (8) r_mat(3,3)
	  real (8) r_matinv(3,3)
	  real (8) r_ov(3)
	  real (8) r_radcur
        end type pegtrans
	type (pegtrans) ptm

        real*8 r_schv(3)              !sch coordinates of a point
        real*8 r_xyzv(3)              !WGS-84 coordinates of a point
        integer i_type                !i_type = 0 sch => xyz ;
                                      !i_type = 1 xyz => sch

c   	OUTPUT VARIABLES: see input

c	LOCAL VARIABLES:
        integer i_t
        real*8 r_schvt(3),r_llh(3)
c	structure /ellipsoid/
c	   real*8 r_a
c	   real*8 r_e2
c	end structure
c	record /ellipsoid/ sph

	type ellipsoid
           sequence
	   real (8) r_a
	   real (8) r_e2
	end type ellipsoid
	type (ellipsoid) sph

c	DATA STATEMENTS:

C	FUNCTION STATEMENTS:none

c  	PROCESSING STEPS:

c       compute the linear portion of the transformation

	sph%r_a = ptm%r_radcur
	sph%r_e2 = 0.0d0

	if(i_type .eq. 0)then

	   r_llh(1) = r_schv(2)/ptm%r_radcur
	   r_llh(2) = r_schv(1)/ptm%r_radcur
	   r_llh(3) = r_schv(3)

           i_t = 1
           call latlon(sph,r_schvt,r_llh,i_t)
           call matvec(ptm%r_mat,r_schvt,r_xyzv)
           call lincomb(1.d0,r_xyzv,1.d0,ptm%r_ov,r_xyzv)

        elseif(i_type .eq. 1)then

	   call lincomb(1.d0,r_xyzv,-1.d0,ptm%r_ov,r_schvt)
           call matvec(ptm%r_matinv,r_schvt,r_schv)
           i_t = 2
           call latlon(sph,r_schv,r_llh,i_t)

           r_schv(1) = ptm%r_radcur*r_llh(2)
           r_schv(2) = ptm%r_radcur*r_llh(1)
           r_schv(3) = r_llh(3)

	endif

	end


text:
!>  \file sfc_diag.f
!!  This file contains the land surface diagnose calculation scheme.

!> \defgroup Sfc_diag Land Surface Diagnose Calculation
!! @{

      module sfc_diag
      contains

      subroutine sfc_diag_init
      end subroutine sfc_diag_init

      subroutine sfc_diag_finalize
      end subroutine sfc_diag_finalize

!> \brief Brief description of the subroutine
!!
!! \section arg_table_sfc_diag_run Arguments
!! | local_name     | standard_name                                                                | long_name                                                   | units         | rank | type      |    kind   | intent | optional |
!! |----------------|------------------------------------------------------------------------------|-------------------------------------------------------------|---------------|------|-----------|-----------|--------|----------|
!! | im             | horizontal_loop_extent                                                       | horizontal loop extent                                      | count         |    0 | integer   |           | in     | F        |
!! | ps             | surface_air_pressure                                                         | surface pressure                                            | Pa            |    1 | real      | kind_phys | in     | F        |
!! | u1             | x_wind_at_lowest_model_layer                                                 | x component of 1st model layer wind                         | m s-1         |    1 | real      | kind_phys | in     | F        |
!! | v1             | y_wind_at_lowest_model_layer                                                 | y component of 1st model layer wind                         | m s-1         |    1 | real      | kind_phys | in     | F        |
!! | t1             | air_temperature_at_lowest_model_layer                                        | 1st model layer air temperature                             | K             |    1 | real      | kind_phys | in     | F        |
!! | q1             | specific_humidity_at_lowest_model_layer                                      | 1st model layer specific humidity                           | kg kg-1       |    1 | real      | kind_phys | in     | F        |
!! | tskin          | surface_skin_temperature                                                     | surface skin temperature                                    | K             |    1 | real      | kind_phys | in     | F        |
!! | qsurf          | surface_specific_humidity                                                    | surface specific humidity                                   | kg kg-1       |    1 | real      | kind_phys | in     | F        |
!! | f10m           | ratio_of_wind_at_lowest_model_layer_and_wind_at_10m                          | ratio of fm10 and fm                                        | ratio         |    1 | real      | kind_phys | out    | F        |
!! | u10m           | x_wind_at_10m                                                                | x component of wind at 10 m                                 | m s-1         |    1 | real      | kind_phys | out    | F        |
!! | v10m           | y_wind_at_10m                                                                | y component of wind at 10 m                                 | m s-1         |    1 | real      | kind_phys | out    | F        |
!! | t2m            | temperature_at_2m                                                            | temperature at 2 m                                          | K             |    1 | real      | kind_phys | out    | F        |
!! | q2m            | specific_humidity_at_2m                                                      | specific humidity at 2 m                                    | kg kg-1       |    1 | real      | kind_phys | out    | F        |
!! | prslki         | ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer | Exner function ratio bt midlayer and interface at 1st layer | ratio         |    1 | real      | kind_phys | in     | F        |
!! | evap           | kinematic_surface_upward_latent_heat_flux                                    | surface upward evaporation flux                             | kg kg-1 m s-1 |    1 | real      | kind_phys | in     | F        |
!! | fm             | Monin-Obukhov_similarity_function_for_momentum                               | Monin-Obukhov similarity parameter for momentum             | none          |    1 | real      | kind_phys | in     | F        |
!! | fh             | Monin-Obukhov_similarity_function_for_heat                                   | Monin-Obukhov similarity parameter for heat                 | none          |    1 | real      | kind_phys | in     | F        |
!! | fm10           | Monin-Obukhov_similarity_function_for_momentum_at_10m                        | Monin-Obukhov similarity parameter for momentum             | none          |    1 | real      | kind_phys | in     | F        |
!! | fh2            | Monin-Obukhov_similarity_function_for_heat_at_2m                             | Monin-Obukhov similarity parameter for heat                 | none          |    1 | real      | kind_phys | in     | F        |
!! | errmsg         | error_message                                                                | error message for error handling in CCPP                    | none          |    0 | character | len=*     | out    | F        |
!! | errflg         | error_flag                                                                   | error flag for error handling in CCPP                       | flag          |    0 | integer   |           | out    | F        |
!!
!!  \section general General Algorithm
!!  \section detailed Detailed Algorithm
!!  @{
! DH* TODO add intent() information for variables
      subroutine sfc_diag_run                                           &
     &                   (im,ps,u1,v1,t1,q1,                            &
     &                    tskin,qsurf,f10m,u10m,v10m,t2m,q2m,           &
     &                    prslki,evap,fm,fh,fm10,fh2,errmsg,errflg      &
     &                   )
!!
!
      use machine , only : kind_phys
      use funcphys, only : fpvs
      use physcons, grav => con_g,  cp => con_cp,                       &
     &              eps => con_eps, epsm1 => con_epsm1
      implicit none
!
      integer              im
      real, dimension(im) :: ps,   u1,   v1,   t1,  q1,  tskin,  qsurf, &
     &                       f10m, u10m, v10m, t2m, q2m, prslki, evap,  &
     &                       fm,   fh,   fm10, fh2
      character(len=*), intent(out) :: errmsg
      integer,          intent(out) :: errflg
!
!     locals
!
      real (kind=kind_phys), parameter :: qmin=1.0e-8
      integer              k,i
!
      real(kind=kind_phys)        fhi, qss, wrk
!     real(kind=kind_phys) sig2k, fhi, qss
!
!     real, parameter :: g=grav
!
      ! Initialize CCPP error handling variables
      errmsg = ''
      errflg = 0
!
!     estimate sigma ** k at 2 m
!
!     sig2k = 1. - 4. * g * 2. / (cp * 280.)
!
!  initialize variables. all units are supposedly m.k.s. unless specified
!  ps is in pascals
!
!!
      do i = 1, im
        f10m(i) = fm10(i) / fm(i)
!       f10m(i) = min(f10m(i),1.)
        u10m(i) = f10m(i) * u1(i)
        v10m(i) = f10m(i) * v1(i)
        fhi     = fh2(i) / fh(i)
!       t2m(i)  = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi
!       sig2k   = 1. - (grav+grav) / (cp * t2m(i))
!       t2m(i)  = t2m(i) * sig2k
        wrk     = 1.0 - fhi

        t2m(i)  = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp

        if(evap(i) >= 0.) then !  for evaporation>0, use inferred qsurf to deduce q2m
          q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi
        else                   !  for dew formation, use saturated q at tskin
          qss    = fpvs(tskin(i))
          qss    = eps * qss / (ps(i) + epsm1 * qss)
          q2m(i) = qss*wrk + max(qmin,q1(i))*fhi
        endif
        qss    = fpvs(t2m(i))
        qss    = eps * qss / (ps(i) + epsm1 * qss)
        q2m(i) = min(q2m(i),qss)
      enddo

      return
      end subroutine sfc_diag_run
!> @}

      end module sfc_diag
!> @}

max_stars_repo_name: cacraigucar/ccpp-physics

max_issues_repo_name: cacraigucar/ccpp-physics

max_forks_repo_name: cacraigucar/ccpp-physics


! PR fortran/72716
! { dg-do compile }

block data
  !$omp declare simd (z)	! { dg-error "statement is not allowed inside of BLOCK DATA" }
end block data