text:
module bgrid_horiz_adjust_mod

!-----------------------------------------------------------------------
!   This modules has interfaces for computing various
!         horizontal adjustment processes.
!
!   1) momentum adjustment using coriolis and pressure gradient
!   2) mass fluxes (used for divergence and advection)
!   3) mass divergence
!   4) thermodynamic term (horizontal part of omega-alpha term)
!   4) pressure gradient (several options)
!   5) grad(p)/p term (used for energy conservation)
!   6) divergence damping
!
!-----------------------------------------------------------------------

use bgrid_horiz_mod      , only: horiz_grid_type
use bgrid_vert_mod       , only: vert_grid_type, compute_pres_depth, &
                                 compute_geop_height, compute_pres_half
use bgrid_masks_mod      , only: grid_mask_type
use bgrid_halo_mod       , only: update_halo, TEMP
use bgrid_change_grid_mod, only: change_grid, TEMP_GRID, WIND_GRID, &
                                              UFLX_GRID, VFLX_GRID

use         constants_mod, only: OMEGA, RADIUS, RDGAS
use               fms_mod, only: error_mesg, FATAL

implicit none
private

public :: horiz_adjust_vel, horiz_adjust_mass, press_grad, &
          div_damping, compute_grad_pres, press_grad_fv

!-----------------------------------------------------------------------

   real, parameter :: RADIUS_INV = 1.0/RADIUS

!-----------------------------------------------------------------------

contains

!#######################################################################

subroutine horiz_adjust_vel ( Hgrid, Masks, dt, &
                              pgfew, pgfns, um, vm, udt, vdt,  &
                              alpha_implicit )

!-----------------------------------------------------------------------
!  update momentum tendencies using coriolis and pressure gradient
!
!    IN: Hgrid  = horizontal grid constants
!        Masks  = grid masking constants
!        dt     = time step
!        pgfew,
!         pgfns = pressure gradient force components (m/s2)
!        um,vm  = zonal and meridional wind components
!
! INOUT: udt,vdt = tendency of zonal and meridional wind components
!
! IN (opt): alpha_implicit = coefficient for coriolis/pgf time diff
!                               0.0 = explicit (not recommended)
!                               0.5 = trapezoidal implicit (default)
!                               1.0 = fully implicit
!
!-----------------------------------------------------------------------
type(horiz_grid_type), intent(in)      :: Hgrid
type (grid_mask_type), intent(in)      :: Masks
   real, intent(in)                    :: dt
   real, intent(in),    dimension(Hgrid%ilb:, Hgrid%jlb:, :) :: &
                                           pgfew, pgfns, um, vm
   real, intent(inout), dimension(Hgrid%ilb:, Hgrid%jlb:, :) :: &
                                                        udt, vdt
real, optional, intent(in)              :: alpha_implicit
!-----------------------------------------------------------------------

  real, dimension (Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub) :: &
      pgfu, pgfv, f0, fa, fb, cu, cv, up, vp, un, vn

    integer :: i, j, k
    real    :: alpha
!-----------------------------------------------------------------------

     alpha = 0.5; if (present(alpha_implicit)) alpha = alpha_implicit
     alpha = min(max(0.0,alpha),1.0)

!-----------------------------------------------------------------------
!-----------------update u and v (coriolis & pgf)-----------------------

      do k =            1, size(um,3)
      do j = Hgrid%Vel%js, Hgrid%Vel%je
      do i = Hgrid%Vel%is, Hgrid%Vel%ie

!     --------- pressure gradient force components---------------

         pgfu(i,j) = dt*pgfew(i,j,k)
         pgfv(i,j) = dt*pgfns(i,j,k)

!     ------------coriolis & curvature terms----------------------

         f0(i,j) = (um(i,j,k)*RADIUS_INV*Hgrid%tanphv(i,j)+  &
                              2.*OMEGA*Hgrid%sinphv(i,j))*dt
         fa(i,j) = f0(i,j)*(1.0-alpha)
         fb(i,j) = f0(i,j)*alpha

         cu(i,j) =  vm(i,j,k)*fa(i,j)
         cv(i,j) = -um(i,j,k)*fa(i,j)

!     ------------compute new u and v (coriolis & pgf)------------

         up(i,j) = pgfu(i,j) + cu(i,j) + um(i,j,k)
         vp(i,j) = pgfv(i,j) + cv(i,j) + vm(i,j,k)

         un(i,j) = ((fb(i,j)*vp(i,j)+up(i,j))/   &
                    (fb(i,j)*fb(i,j)+1.0))*Masks%Vel%mask(i,j,k)
         vn(i,j) = (vp(i,j)-fb(i,j)*un(i,j))*Masks%Vel%mask(i,j,k)

!     ---- return unfiltered tendencies with halos not updated ----

         udt(i,j,k) = udt(i,j,k) + (un(i,j)-um(i,j,k))/dt
         vdt(i,j,k) = vdt(i,j,k) + (vn(i,j)-vm(i,j,k))/dt
      enddo
      enddo
      enddo

!-----------------------------------------------------------------------

end subroutine horiz_adjust_vel

!#######################################################################

 subroutine horiz_adjust_mass ( nplev, Hgrid, Masks,  &
                                u, v, dpde, cew, cns,        &
                                flew, flns, div, omgalf      )

!-----------------------------------------------------------------------
!  Computes:  mass fluxes, divergence, thermodynamic term (horiz part)
!
!    IN: nplev  = vertical index of uppermost pure pressure level
!                 (use nplev=0 for sigma models)
!        Hgrid  = horizontal grid constants
!        Masks  = grid masking constants
!        u, v   = prognostic variables for zonal and meridional wind
!        dpde   = pressure thickness of model layers
!        cew,
!          cns  = zonal and meridional components of grad(p)/p (no units)
!
! INOUT: flew,
!          flns = zonal, meridional mass fluxes (summation) (Pa-m2/s)
!
!   OUT: div    = mass divergence (Pa/s)
!        omgalf = horizontal part of omega-alpha term (Pa/s)
!
!-----------------------------------------------------------------------
integer, intent(in)                   :: nplev
type(horiz_grid_type), intent(inout)  :: Hgrid
type (grid_mask_type), intent(in)     :: Masks
  real, intent(in),    dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: u, v, &
                                                        dpde, cew, cns
  real, intent(inout), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: flew, flns
  real, intent(out),   dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: div, omgalf
!-----------------------------------------------------------------------

    real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub) ::   &
                                  few, fns, udy, vdx, tew, tns, adpdxy

    integer :: i, j, k, is, ie, js, je

    is = Hgrid%Tmp%is;  ie = Hgrid%Tmp%ie
    js = Hgrid%Tmp%js;  je = Hgrid%Tmp%je

!-----------------------------------------------------------------------

!-----------------------------------------------------------------------

      few = 0.0;  fns = 0.0

   do k = 1, size(u,3)

     !---- average mass weights for mass fluxes ----
      call change_grid ( Hgrid, TEMP_GRID, WIND_GRID, dpde(:,:,k), adpdxy )

!---- compute mass fluxes, divergence & horizontal omega-alpha term ----
!-------add in compute flux corrections for grid separation ------------
!---- sum input/output mass fluxes -------

      do j = js-1, je+1
         udy(:,j)=Hgrid%Vel%dy   *u(:,j,k)*adpdxy(:,j)   *Masks%Vel%mask(:,j,k)
         vdx(:,j)=Hgrid%Vel%dx(j)*v(:,j,k)*adpdxy(:,j)   *Masks%Vel%mask(:,j,k)
      enddo

      do j = js,   je
      do i = is-1, ie
          few(i,j)   = (udy(i,j)+udy(i,j-1))*0.5
          tew(i,j)   = few(i,j)*cew(i,j,k)
      enddo
      enddo
      do j = js-1, je
      do i = is,   ie
          fns(i,j)   = (vdx(i,j)+vdx(i-1,j))*0.5
          tns(i,j)   = fns(i,j)*cns(i,j,k)
      enddo
      enddo

!-----------------------------------------------------------------------
! ------ sum fluxes (output needed for advection) ------
! ------ (halos will be updated in advection) ------

      flew(:,:,k) = flew(:,:,k) + few
      flns(:,:,k) = flns(:,:,k) + fns

!---------------------------divergence----------------------------------

      do j = js, je
      do i = is, ie
         div(i,j,k) = ((few(i  ,j)+fns(i,j  ))-  &
                       (few(i-1,j)+fns(i,j-1)))  &
                        *Hgrid%Tmp%rarea(j)*Masks%Tmp%mask(i,j,k)
      enddo
      enddo

!-------------- horizontal part of omega-alpha -------------------------
!        ------ do not do for pure pressure levels -----

      if (k > nplev) then
         do j = js, je
         do i = is, ie
            omgalf(i,j,k)=(tew(i,j)+tew(i-1,j)+tns(i,j)+tns(i,j-1)) &
                          *0.50*Hgrid%Tmp%rarea(j)*Masks%Tmp%mask(i,j,k)
         enddo
         enddo
      else
            omgalf(:,:,k) = 0.0
      endif

!-----------------------------------------------------------------------
!---- end level loop -----

   enddo

!-----------------------------------------------------------------------

 end subroutine horiz_adjust_mass

!#######################################################################
!        Simmons and Burridge (1981) pressure gradient

subroutine press_grad ( Hgrid, Vgrid, Masks, fssl, tq,         &
                        dpde, wta, wtb, cew, cns, pgfew, pgfns )

!-----------------------------------------------------------------------
!    IN: Hgrid  = horizontal constants
!        Vgrid  = vertical constants
!        Masks  = grid masking constants
!        fssl   = geopotential height (m2/s2) at eta=1.
!        tq     = virtual temperature
!        dpde   = pressure thickness of model layers
!        wta,
!          wtb  = weights for computing geopotential height
!                 (same as weight for computing full pressures)
!        cew,
!          cns  = zonal and meridional components of grad(p)/p
!
!   OUT: pgfew,
!         pgfns = pressure gradient force components (m/s2)
!
!-----------------------------------------------------------------------
type(horiz_grid_type), intent (inout) :: Hgrid
type (vert_grid_type), intent (in)  :: Vgrid
type (grid_mask_type), intent (in)  :: Masks
   real, intent (in) , dimension(Hgrid%ilb:Hgrid%iub, &
                                 Hgrid%jlb:Hgrid%jub) :: fssl
   real, intent (in),  dimension(Hgrid%ilb:Hgrid%iub, &
                                 Hgrid%jlb:Hgrid%jub,Vgrid%nlev) :: &
                                       tq, dpde, wta, wtb, cew, cns
   real, intent (out), dimension(Hgrid%ilb:Hgrid%iub, &
                                 Hgrid%jlb:Hgrid%jub,Vgrid%nlev) :: &
                                       pgfew, pgfns

!-----------------------------------------------------------------------
  real, dimension (Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub) :: &
                                       pew, pns, tew, tns

  real, dimension (Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub,  &
                   size(tq,3)) :: fim, ppcew, ppcns

    integer :: i, j, k, is, ie, js, je
!-----------------------------------------------------------------------
!------------- integration of geopotential height-----------------------
!        fim = geopotential height at model levels

   if (Vgrid%nlev /= size(tq,3)) call error_mesg ('geop_height',  &
                              'wrong number of vertical levels', FATAL)

   if (Vgrid%nlev > 1) then

       call compute_geop_height (Vgrid, fssl, tq, wta, wtb, fim, &
                                 mask=Masks%Tmp%mask)

   else

       fim(:,:,:) = dpde(:,:,:) ! special case for shallow water model

   endif

!----------- lat/lon contributions to pressure gradient ----------------
!   -------- two loops: pressure only, pressure/sigma -------
!   ppcew,ppcns = zonal and meridional auxillary pressure gradient
!                 force components (i.e., not on velocity grid)

   is = Hgrid%Vel%is;  ie = Hgrid%Vel%ie
   js = Hgrid%Vel%js;  je = Hgrid%Vel%je

   ! compute at pure pressure levels
   do k =  1, Vgrid%nplev
     do j = js, je+1
     do i = is, ie
       ppcew(i,j,k) = fim(i+1,j,k)-fim(i,j,k)
     enddo
     enddo
     do j = js, je
     do i = is, ie+1
       ppcns(i,j,k) = fim(i,j+1,k)-fim(i,j,k)
     enddo
     enddo
   enddo

   ! compute at sigma/pressure levels
   do k = Vgrid%nplev+1, Vgrid%nlev
     do j = js, je+1
     do i = is, ie
         pew(i,j)   = fim(i+1,j,k)-fim(i,j,k)
         tew(i,j)   = RDGAS*0.50*(tq(i+1,j,k)+tq(i,j,k))
       ppcew(i,j,k) = pew(i,j)+tew(i,j)*cew(i,j,k)
     enddo
     enddo
     do j = js, je
     do i = is, ie+1
         pns(i,j)   = fim(i,j+1,k)-fim(i,j,k)
         tns(i,j)   = RDGAS*0.50*(tq(i,j+1,k)+tq(i,j,k))
       ppcns(i,j,k) = pns(i,j)+tns(i,j)*cns(i,j,k)
     enddo
     enddo
   enddo

!--------------compute pressure gradient force components---------------

   do k =  1, Vgrid%nlev
   do j = js, je
   do i = is, ie
      pgfew(i,j,k)=-0.50*(ppcew(i,j,k)+ppcew(i,j+1,k))*Hgrid%Vel%rdx(j)
      pgfns(i,j,k)=-0.50*(ppcns(i,j,k)+ppcns(i+1,j,k))*Hgrid%Vel%rdy
   enddo
   enddo
   enddo

!-----------------------------------------------------------------------

 end subroutine press_grad

!#######################################################################
!      code for Lin (1997) finite volume pressure gradient

 subroutine press_grad_fv ( Hgrid, Vgrid, Masks, fssl, tq, phalf, &
                            wta, wtb, pgfew, pgfns                )

!-----------------------------------------------------------------------
!    IN: Hgrid  = horizontal constants
!        Vgrid  = horizontal constants
!        Masks  = grid masking constants
!        fssl   = geopotential height (m2/s2) at eta=1.
!        tq     = virtual temperature
!        phalf  = pressure at model layer interfaces
!        wta,
!          wtb  = weights for computing geopotential height
!                 (same as weight for computing full pressures)
!   OUT: pgfew,
!         pgfns = pressure gradient force components (m/s2)
!-----------------------------------------------------------------------
type(horiz_grid_type), intent (inout) :: Hgrid
type (vert_grid_type), intent (in)  :: Vgrid
type (grid_mask_type), intent (in)  :: Masks
   real, intent (in) , dimension(Hgrid%ilb:Hgrid%iub, &
                                 Hgrid%jlb:Hgrid%jub) :: fssl
   real, intent (in),  dimension(Hgrid%ilb:Hgrid%iub, &
                                 Hgrid%jlb:Hgrid%jub,Vgrid%nlev+1) :: &
                                       phalf
   real, intent (in),  dimension(Hgrid%ilb:Hgrid%iub, &
                                 Hgrid%jlb:Hgrid%jub,Vgrid%nlev) :: &
                                       tq, wta, wtb
   real, intent (out), dimension(Hgrid%ilb:Hgrid%iub, &
                                 Hgrid%jlb:Hgrid%jub,Vgrid%nlev) :: &
                                       pgfew, pgfns

!-----------------------------------------------------------------------
  real, dimension (Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub) :: &
                                       few, pew, fns, pns
  real, dimension (Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub,  &
                   size(tq,3)+1) :: fi, pi
  real   :: dp1, dp2
  integer :: i, j, k, is, ie, js, je

!------------- integration of geopotential height-----------------------
!        fi = geopotential height at half levels
!        pi = ln pressure at half levels

   if (Vgrid%nlev /= size(tq,3)) call error_mesg ('geop_height',  &
                              'wrong number of vertical levels', FATAL)

 ! initialize
     is = Hgrid%Vel%is;  ie = Hgrid%Vel%ie
     js = Hgrid%Vel%js;  je = Hgrid%Vel%je

 ! define ln pressure
     pi(:,:,2:Vgrid%nlev+1) = log(phalf(:,:,2:Vgrid%nlev+1))
     if (Vgrid%pzero) then
 ! extrapolate when pressure at top = 0
       ! following simmons & burridge scheme
       pi(:,:,1) = 2.*pi(:,:,2)*phalf(:,:,2)/(phalf(:,:,2)-phalf(:,:,1)) - &
                      pi(:,:,2) - 2.
     else
       pi(:,:,1) = log(phalf(:,:,1))
     endif

 ! compute geop height at model layer interfaces
 ! integrate up from surface
     fi(:,:,Vgrid%nlev+1) = fssl
  if (Masks%sigma) then
     do k = Vgrid%nlev, 1, -1
        fi(:,:,k) = fi(:,:,k+1) + RDGAS*tq(:,:,k)*(pi(:,:,k+1)-pi(:,:,k))
     enddo
  else
     do k = Vgrid%nlev, 1, -1
        where (Masks%Tmp%mask(:,:,k) < 0.5)
            fi(:,:,k) = Vgrid%fhalf(k)
        elsewhere
            fi(:,:,k) = fi(:,:,k+1) + RDGAS*tq(:,:,k)*(pi(:,:,k+1)-pi(:,:,k))
        endwhere
     enddo
  endif

 ! loop over levels
   do k = 1, Vgrid%nlev

   ! compute pressure gradient at intermediate points
   ! E/W component
     do j = js, je+1
     do i = is, ie
        dp1 = pi(i+1,j,k+1) - pi(i  ,j,k)
        dp2 = pi(i  ,j,k+1) - pi(i+1,j,k)
        few(i,j) = (dp1*(fi(i,j,k+1)-fi(i+1,j,k)) + dp2*(fi(i,j,k)-fi(i+1,j,k+1)))
        pew(i,j) = dp1+dp2
     enddo
     enddo
   ! N/S component
     do j = js, je
     do i = is, ie+1
        dp1 = pi(i,j+1,k+1) - pi(i,j  ,k)
        dp2 = pi(i,j  ,k+1) - pi(i,j+1,k)
        fns(i,j) = (dp1*(fi(i,j,k+1)-fi(i,j+1,k)) + dp2*(fi(i,j,k)-fi(i,j+1,k+1)))
        pns(i,j) = dp1+dp2
     enddo
     enddo

   ! compute pressure gradient at velocity points
     do j = js, je
     do i = is, ie
        pgfew(i,j,k) = (few(i,j)+few(i,j+1))/(pew(i,j)+pew(i,j+1))*Hgrid%Vel%rdx(j)
        pgfns(i,j,k) = (fns(i,j)+fns(i+1,j))/(pns(i,j)+pns(i+1,j))*Hgrid%Vel%rdy
     enddo
     enddo

   enddo

 end subroutine press_grad_fv

!#######################################################################
!   compute grad P term consistent with Simmons and Burridge

 subroutine compute_grad_pres (Hgrid, nplev, phalf, dpde, &
                               wta, wtb, cew, cns)

!-----------------------------------------------------------------------
!   IN:  Hgrid  = horizontal constants
!        nplev  = vertical index of uppermost pure pressure level
!                 (use nplev=0 for sigma models)
!        phalf  = pressure at model layer interfaces
!        dpde   = pressure thickness of model layers
!        wta,
!          wtb  = weights for computing geopotential height
!                 (same as weight for computing full pressures)
!  OUT:  cew,
!          cns  = zonal and meridional components of grad(p)/p (no units)
!-----------------------------------------------------------------------

   type(horiz_grid_type), intent(in)  :: Hgrid
   integer,               intent(in)  :: nplev
   real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:) ::  &
                                       phalf, dpde, wta, wtb
   real, intent(out), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: cew, cns

   real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub) :: &
                                   pewa, pewb, pnsa, pnsb
   real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub, &
                                        size(dpde,3)) :: adpdx, adpdy
   integer :: i, j, k

 ! special case for one level model
   if (size(dpde,3) == 1) then
       cew(:,:,:) = 0.0
       cns(:,:,:) = 0.0
       return
   endif

 ! term vanishes on pressure levels
   do k = 1, nplev
       cew(:,:,k) = 0.0
       cns(:,:,k) = 0.0
   enddo

!---- compute pressure depth at uflx and vflx points ----

   call change_grid (Hgrid, TEMP_GRID, UFLX_GRID, dpde(:,:,:), adpdx)
   call change_grid (Hgrid, TEMP_GRID, VFLX_GRID, dpde(:,:,:), adpdy)

! --- compute pressure differences ----

   do j = Hgrid%Tmp%js,   Hgrid%Tmp%je+1
   do i = Hgrid%Tmp%is-1, Hgrid%Tmp%ie
      pewa(i,j) = phalf(i+1,j,nplev+1)-phalf(i,j,nplev+1)
   enddo
   enddo

   do j = Hgrid%Tmp%js-1, Hgrid%Tmp%je
   do i = Hgrid%Tmp%is,   Hgrid%Tmp%ie+1
      pnsa(i,j) = phalf(i,j+1,nplev+1)-phalf(i,j,nplev+1)
   enddo
   enddo

! --- compute grad pressure term at model levels ----

   do k = nplev+1, size(phalf,3)-1

      !---- east-west contribution ----
       do j = Hgrid%Tmp%js,   Hgrid%Tmp%je+1
       do i = Hgrid%Tmp%is-1, Hgrid%Tmp%ie
           pewb(i,j) = phalf(i+1,j,k+1)-phalf(i,j,k+1)
           cew(i,j,k) = (wta(i+1,j,k)+wta(i,j,k)) * pewa(i,j) + &
                        (wtb(i+1,j,k)+wtb(i,j,k)) * pewb(i,j)
           cew(i,j,k) = 0.5 * cew(i,j,k) / adpdx(i,j,k)
           pewa(i,j) = pewb(i,j)
       enddo
       enddo
      !---- north-south contribution ----
       do j = Hgrid%Tmp%js-1, Hgrid%Tmp%je
       do i = Hgrid%Tmp%is,   Hgrid%Tmp%ie+1
           pnsb(i,j) = phalf(i,j+1,k+1)-phalf(i,j,k+1)
           cns(i,j,k) = (wta(i,j+1,k)+wta(i,j,k)) * pnsa(i,j) + &
                        (wtb(i,j+1,k)+wtb(i,j,k)) * pnsb(i,j)
           cns(i,j,k) = 0.5 * cns(i,j,k) / adpdy(i,j,k)
           pnsa(i,j) = pnsb(i,j)
       enddo
       enddo
   enddo

 end subroutine compute_grad_pres

!#######################################################################

 subroutine div_damping (Hgrid, Vgrid, Masks, dt, coeff, dpde, div,  &
                         u_dt, v_dt)

!-----------------------------------------------------------------------
!
!   Computes divergence damping tendency for momentum fields
!
!    IN: Hgrid  = horizontal constants
!        Vgrid  = horizontal constants
!        Masks  = grid masking constants
!        dt     = time step
!        coeff  = coefficient for divergence damping
!        dpde   = model layer pressure thickness
!        div    = mass divergence (Pa/s)
!
! INOUT: u_dt,
!          v_dt = zonal and meridional momentum tendencies (m/s2)
!
!-----------------------------------------------------------------------

type(horiz_grid_type), intent (inout)  :: Hgrid
type (vert_grid_type), intent (in)  :: Vgrid
type (grid_mask_type), intent (in)  :: Masks
 real, intent (in)                  :: dt, coeff
 real, intent (in) ,   dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: dpde, div
 real, intent (inout), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: u_dt, v_dt

!-----------------------------------------------------------------------

  real, dimension (Hgrid%jlb:Hgrid%jub) :: scoeff
  real, dimension (Hgrid%ilb:Hgrid%iub, &
                   Hgrid%jlb:Hgrid%jub) :: dew, dns, adpdxy
  real, dimension (Hgrid%ilb:Hgrid%iub, &
                   Hgrid%jlb:Hgrid%jub,size(div,3)) :: adiv

  real    :: dcoeff
  integer :: i, j, k, is, ie, hs, he, vs, ve, ks, ke
  logical :: fourth_order
!-----------------------------------------------------------------------

  is = Hgrid % Vel % is;  ie = Hgrid % Vel % ie
  vs = Hgrid % Vel % js;  ve = Hgrid % Vel % je
  hs = Hgrid % Tmp % js;  he = Hgrid % Tmp % je
  ks = 1
  ke = size(div,3)
  fourth_order = .false.
  if (coeff < 0.0) fourth_order = .true.
  scoeff = abs(coeff)
  ! maximum damping at the sub-pole row
  ! if (vs == Hgrid%Vel%jsg) scoeff(vs) = 1.0
  ! if (ve == Hgrid%Vel%jeg) scoeff(ve) = 1.0

  if (fourth_order) then
     ! additional 5-pt smoother when fourth-order
     scoeff = -0.50*(scoeff/8.)**2/dt
     do k = ks, ke
        do j = hs-1, he
        do i = is-1, ie
           dew(i,j) = div(i+1,j,k)-div(i,j,k)
           dns(i,j) = div(i,j+1,k)-div(i,j,k)
        enddo
        enddo

        do j = hs, he
        do i = is, ie
           adiv(i,j,k) = (dew(i,j)+dns(i,j)-dew(i-1,j)-dns(i,j-1))
        enddo
        enddo
     enddo

     call update_halo ( Hgrid, TEMP, adiv )
  else
     ! second order
     scoeff = 0.50*(scoeff/8.)/dt
     do k = ks, ke
     do j = hs-1, he+1
        adiv(:,j,k) = div(:,j,k)
     enddo
     enddo
  endif

! second-order scheme (only the gradient)
  do k = ks, ke
     do j = vs, ve+1
     do i = is, ie
        dew(i,j) = adiv(i+1,j,k)-adiv(i,j,k)
     enddo
     enddo
     do j = vs, ve
     do i = is, ie+1
        dns(i,j) = adiv(i,j+1,k)-adiv(i,j,k)
     enddo
     enddo

     call change_grid ( Hgrid, TEMP_GRID, WIND_GRID, dpde(:,:,k), adpdxy )

     do j = vs, ve
     do i = is, ie
        dcoeff = scoeff(j) / adpdxy(i,j) * Masks%Vel%mask(i,j,k)
        u_dt(i,j,k) = u_dt(i,j,k) + (dew(i,j)+dew(i,j+1)) * dcoeff * Hgrid%Vel%dx(j)
        v_dt(i,j,k) = v_dt(i,j,k) + (dns(i,j)+dns(i+1,j)) * dcoeff * Hgrid%Vel%dx(j)
     enddo
     enddo
  enddo

!-----------------------------------------------------------------------

 end subroutine div_damping

!#######################################################################

end module bgrid_horiz_adjust_mod

max_stars_repo_name: JoyMonteiro/FMSDynamicalCore


text:
The UC Davis Religious Studies department offers both major and minor programs specializing in world and local religions. They even have a website that tells you more!

The department office is located on the 6th floor of Sproul Hall and is headed by Naomi Janowitz. Popular professors within the department have included Naomi Janowitz, Whalen Lai, and formerly, Lincoln Hurst.

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C File VAPMN_CRAY
C  This file contains the mid-level routines for the Finite Difference Migration
C They are responsible for the calculating the next time slice at the current
C Tau step.
C
C  This is the CRAY version of the routines which have been rewritten so that
C they vectorize on the CRAY. Also the order of calculation has been modified
C to reduce the Number of floating point operations per time slice. This
C is at the expense of greater memory use through APSCR
C
C  VSFDMCAL - Entry routine from FDMLIN. Responsible for calling routines to
C             calculate RHS & LHS of difference equation. Also shift time
C             slices in memory in preparation for next calculation.
C  VSFDMCAP - Responsible for calculating g on LHS of Recurrence relation.
C             Calls routines to calculate P at this time slice and Tau Step
C  VSFDMCAR - Calculates the RHS of the Difference equation.
C
C  VSFDMRUV - A glue routine that calls VSRUVAPS
C  VSRUVAPS - AP Simulator routine to recusively calculate U & V. This is an
C             intermediate stage to calculating the new Pressure
C
C  VSFDMPN1 - A glue routine that calls VSPN1APS
C  VSPN1APS - AP Simulator routine that calculate the new P given U and V
C
C===============================================================================

        subroutine VSFDMCAL (ac, apn, apnj1, apnj2, apn1, apn1j1,
     +          apn1j2, as3, mx)
        INTEGER ac, apn, apnj1, apnj2, apn1, apn1j1, apn1j2, as3, mx
C-------------------------------------------------------------------------------
C FDM: Calculate the cR" terms and the next time slice, etc. (simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: April, 1985
C
C ENTRY NAMES:  APSFDMCAL
C
c FUNCTION:     1- Calculates the three "R" terms. (See FDMCAR)
c               2- Recursively calculates the next Tau sample P(n+1).
c                  (See FDMCAP)
c               3- Moves the calculated sample back in place and "rotates" the
c                  samples for calculating the next Tau sample.
c
c PARAMETERS:   All parameters beginning with the letter "A" refer to main data
c               (MD) memory locations. (Further notes in FDMCAR and FDMCAP.)
c               AC      = C'
c               APN     = P(n,j)
c               APNJ1   = P(n,j+1)
c               APNJ2   = P(n,j+2)
c               APN1    = P(n+1,j)
c               APN1J1  = P(n+1,j+1)
c               APN1J2  = P(n+1,j+2)
c               AS3     = scratch
c               MX      = Number of traces in each time slice.
c
C CALLED BY:    FDMCAL (which is called by FDMLIN)
C
C EXTERNALS:    FDMCAR, FDMCAP, VMOV
C
C ERRORS & LIMITATIONS: none
C
C REFERENCES:   1- H.Brysk, GEOPHYSICS, volume 48, no.5 (May 1983), p(532-542).
C               2- FDMCAR and FDMCAP notes and FDM design notes.
C REVISIONS:
C
C AUTHOR:   a.j.h                           DATE:  4/11/89
C DESCRIPTION:   Added Call to blkmov to shift the Time slices in APSCR
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
        INTEGER ar, ag, au, av, as1
C
C....   Assign scratch arrays and do it.
C
        ar = apn1                                                       ! Setup AP memory location equivalences
        ag = as3
        au = apn1j2
        av = apnj2
        as1= apn1j2
C..                                        Calculate RHS of Recursion relation
        CALL VSFDMCAR (ac, apn, apnj1, apnj2, ar, apn1j1, apn1j2, as3,
     +   mx)
C..                                        Calculate updated P at this time step
        CALL VSFDMCAP (apn, apn1, ag, au, av, ac, ar, as1, mx)
C
        CALL apsVMOV (apnj1,1,  apnj2,1,  mx)                           ! Shift time slices in AP memory
        CALL apsVMOV (apn,1,    apnj1,1,  mx)
        CALL apsVMOV (apn1j1,1, apn1j2,1, mx)
        CALL apsVMOV (apn1,1,   apn1j1,1, mx)
        CALL apsVMOV (apn1,1,   apn,1,    mx)
        CALL blkmov  (auxscr3, auxscr5, mx)                             ! Move   (P(n+1,j+1) - P(n,j+1))
        CALL blkmov  (auxscr4, auxscr6, mx)                             ! Move T*(P(n+1,j+1) - P(n,j+1))
        RETURN
        END                                                             ! of routine VSFDMCAL

C===============================================================================

        SUBROUTINE vsfdmcap (apn, apn1, ag, au, av, ac, ar, as1, mx)
        INTEGER apn, apn1, ag, au, av, ac, ar, as1, mx
C-------------------------------------------------------------------------------
C$R     FDM: Calculate the next time slice for the current Tau step. (simulator)
C
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  APSFDMCAP
C
c FUNCTION:     For the current sample we require the following recursions:
c
c               (1) P'(m) = v(m) - u(m)P'(m+1)
c
c                   P(n+1,j,m) = P(n,j,m) + P'(m), for m = MX to 1.
c
c               (2)                g(m)
c                   u(m) = ----------------------,
c                          1 - 2g(m) - g(m)u(m-1)
c
c                                (         R(m) )
c                   v(m) = -u(m) (v(m-1) - ---- ), m = 1, MX.
c                                (         g(m) )
c
c               Where:  g(m)    = gamma - a*theta - b
c                       a       = delta-tau * C'
c                       b       = delta-t / 4 * C'
c                       C'      = (C**2 * delta-t) / (4 * delta-x**2)
c                       C       = 1/2 of the RMS velocity for the Tau step.
c                       P(n+1,j,m) = samples calculated at the current Tau step.
c                       P(n,j,m)= samples at the previous Tau step.
c                       P'(m)   = intermediate result (not saved - see FDMPN1)
c                       u(m)    = intermediate result (not saved - see FDMRUV)
c                       v(m)    = intermediate result (not saved - see FDMRUV)
c                       R(m)    = sum of 3 terms (see FDMCAR)
c
c               The processing order is
c                       1 - Calculate g.
c                       2 - Calculate u and v using equation (2) (see FDMRUV).
c                       3 - Calculate P(n+1,j) using equation (1) (see FDMPN1).
c
c PARAMETERS:   All parameters beginning with the letter "A" refer to main data
c               (MD) memory arrays.
c               All arrays are input except for APN1 (output) and AS1 (scratch).
c
c               APN     = P(n,j) - Sample j from previous Tau step n for all m.
c               APN1    = P(n+1,j) - Output sample j for Tau step n+1 for all m.
c               AG      = g.
c               AU      = u.
c               AV      = v.
c               AC      = C'.
c               AR      = R.
c               AS1     = Scratch.
c               MX      = X dimension of time slice (number of traces).
c
c               The following constants are assumed to be in lower main data
c               memory locations when this routine is called:
c               parameter       location        reference name
c               gamma            3              AGAMMA
c               theta            7              ATHETA
c               delta-tau        8              ADTAU
c               delta-t / 4     10              ADT4
c
C CALLED BY:    FDMCAP (which is called by FDMLIN)
C
C EXTERNALS:    VCLR, VMUL, VSUB, FDMRUV and FDMPN1.
C
C ERRORS & LIMITATIONS: Refer to FDMCAP.VFC
C
C REFERENCES:   Refer to FDMCAP.VFC
C
C REVISIONS:
C AUTHOR:  a.j.h                                     DATE:  4/11/89
C DESCRIPTION:  Changed calculation of g(m) so that it is calculated in a
C               single vector loop. CDIR$ IVDEP forces CRAY to ignore possible
C               vector dependencies.
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
        INTEGER agamma, atheta, adtau, adt4
C
        agamma =  3                                                     ! Set up AP low memory locations
        atheta =  7
        adtau  =  8
        adt4   = 10
C
C....   1 - Calculate g.
          tpscal = apdata(adtau) * apdata(atheta) + apdata(adt4)
          tpgam  = apdata(agamma)
c
c.. Ignore vector dependency
CDIR$ IVDEP
          do 10 i = 0, mx-1
           apdata(ag + i) = tpgam - tpscal * apdata(ac+i)
c	 if( apdata(ag + i) .EQ. 0 ) THEN
c	 print *,' i=',i,' ag=',ag,apdata(ag + i),tpgam,tpscal,apdata(ac+i)
c  i=  0 ag=  4999950  0.   0.125000    5.06000E-02    2.47036
c         ac = C'
c                       C'      = (C**2 * delta-t) / (4 * delta-x**2)
c                       C       = 1/2 of the RMS velocity for the Tau step.
c	 stop
c	 endif
  10      continue
C
C....   2- Calculate u and v.
        CALL vsfdmruv (ag, ar, au, av, mx)
C
C....   3- Calculate P(n+1,j).
        CALL vsfdmpn1 (apn, au, av, apn1, mx)
        return
        END                                                             ! of routine vsfdmcap

C===============================================================================

        SUBROUTINE vsfdmcar (ac, apn, apnj1, apnj2, ar, apn1j1,
     +          apn1j2, as3, mx)
        INTEGER ac, apn, apnj1, apnj2, ar, apn1j1, apn1j2, as3, mx
C------------------------------------------------------------------------------
C$R     FDM: Calculate the 3 cR" terms. (Simulator)
C
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  APSFDMCAR
C
c FUNCTION:     This routine evaluates the terms on the right-hand side of the
c               following equation:
c               R(m) = [1 - (gamma - a*theta - b) * T] (P(n+1,j,m) - P(n,j,m)
c                =   2*rho [1 - (gamma+b) * T]
c                               (P(n+1,j+1,m) - P(n,j+1,m)              (term 1)
c                  - rho**2 [1 - (gamma + a*theta -b) * T]
c                               (P(n+1,j+2,m) - P(n,j+2,m))             (term 2)
c                  + a*T (rho**2 * P(n,j+2,m) - P(n,j,m)),              (term 3)
c               where
c                       m       = 1 to MX.
c                       a       = delta tau * C'
c                       b       = delta t/4 * C'
c                       C'      = (C**2 * delta t) / (4 * delta x**2)
c                       C       = 1/2 of the RMS velocity for the Tau interval.
c                       P(n,j..j+2) = Samples from the previous Tau step, n.
c                       P(n+1,j..j+2) = Samples of the current Tau step, n+1.
c                                 (P(n+1,j) is the desired time slice.)
c                       T       = 3 point convolutional operator = (-1, 2, -1).
c                       R       = The calculated value of the three terms.
c
c PARAMETERS:   All parameters begining with the letter "A" refer to main data
c               (MD) memory locations and arrays. All arrays are input except
c               AR and AS3. (NOTE: All arrays are assumed to have 0-elements at
c               at either end so that the convolution with the 3 point "T"
c               operator will work. Ie. APN(-1)=0 and APN(MX)=0.)
c               AC      = C'.
c               APN     = P(n,j)
c               APNJ1   = P(n,j+1)
c               APNJ2   = P(n,j+2) (will be scratched)
c               AR      = R. (output)
c               APN1J1  = P(n+1,j+1)
c               APN1J2  = P(n+1,j+2) (will be scratched)
c               AS3     = scratch.
c               MX      = X-dimension of each time slice (number of traces).
c
c               The following constants are expected in lower MD memory:
c               parameter       location        referenced as
c               T               0..2            AT
c               gamma            3              AGAMMA
c               rho              4              ARHO
c               rho**2           5              ARHOSQ
c               2 * rho          6              A2RHO
c               theta            7              ATHETA
c               delta tau        8              ADTAU
c               delta t          9              ADT
c               delta t / 4     10              ADT4
c
C
C CALLED BY:    FDMCAR (which is called by FDMLIN).
C
C EXTERNALS:    TCONV
C
C ERRORS & LIMITATIONS: None.
C
C REFERENCES:   Refer to FDMCAR.VFC
C
C REVISIONS:
C AUTHOR:  a.j.h.                                   DATE: 11/4/89
C DESCRIPTION:
C    This routine was almost completely rewritten although it is functinally
C equivalent to the previous AP simulator code.
C    This version calculates most of R in a single vector do loop. However, it
C does calculate the majority of term 3 separately
C    It uses (P(n+1,j+2) - P(n,j+2)) and T*(P(n+1,j+2) - P(n,j+2)) stored in
C APSCR from the previous time step
C   The final do loop is somewhat ungainly and even on the Cray it may be better
C to split into smaller vector loops
C-------------------------------------------------------------------------------
C
        INTEGER agamma, arhosq, a2rho, atheta, adtau, adt4
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
C....   Define some other array names and constants.
C
        agamma  = 3                                                     ! gamma
        arhosq  = 5                                                     ! rho ** 2
        a2rho   = 6                                                     ! 2 * rho
        atheta  = 7                                                     ! theta
        adtau   = 8                                                     ! delta tau
        adt4    =10                                                     ! delta t / 4
C
C
      sc2rho  = apdata(a2rho)
      sc2     = sc2rho * apdata(agamma)
      sc3     = sc2rho * apdata(adt4)
      scrhosq = apdata(arhosq)
      scdtau  = apdata(adtau)
      sc6     = scrhosq * apdata(agamma)
      sc7     = scrhosq * (scdtau * apdata(atheta) - apdata(adt4))
C
C....   Calculate term 3 T* (rho**2 * P(n,j+2) - P(n,j)):
      do 10 ii = -1, mx+1                                               ! Must ensure end traces are 0. for T*
        apscr(auxscr1+ii) = scrhosq * apdata(apnj2+ii)
     $                                      - apdata(apn+ii)
   10 continue
C
      call TCONV(apscr(auxscr1-1),apscr(auxscr2),mx)
C
C.. The next two terms are reused at the next time step (see VSFDMCAL)
C
C...  Calculate term P(n+1,j+1) - P(n,j+1)
      do 20 ii = -1, mx+1                                               ! Must ensure end traces are 0. for T*
        apscr(auxscr3 + ii) = apdata(apn1j1 + ii) - apdata(apnj1 + ii)
   20 continue
C
C.... Calculate term T* (P(n+1,j+1) - P(n,j+1))
      call TCONV(apscr(auxscr3-1),apscr(auxscr4),mx)
C
C                                      Calculate R
C Ignore apparent Vector dependencies
CDIR$ IVDEP
      do 30 ii = 0, mx-1
        apdata(ar+ii) =
     $                           sc2rho * apscr(auxscr3+ii)
     $    - (sc2 + sc3 * apdata(ac+ii)) * apscr(auxscr4+ii)
     $    -                     scrhosq * apscr(auxscr5+ii)
     $    + (sc6 + sc7 * apdata(ac+ii)) * apscr(auxscr6+ii)
     $    +     scdtau * apdata(ac+ii)  * apscr(auxscr2+ii)
   30 continue
      RETURN
      END                                                               ! of routine VSFDMCAR

C===============================================================================

        SUBROUTINE vsfdmpn1 (pn, u, v, pn1, mx)
        INTEGER pn, u, v, pn1, mx
C-------------------------------------------------------------------------------
C$R     FDM: Recursively calculate the next time slice, P(n+1,j). (Simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  APSFDMPN1
C
C COMMON:       /AP120B_MD/ - Main Data (MD) memory simulator buffer.
C
C CALLED BY:    FDMPN1.APL (which is called by FDMCAP.VFC)
C
C EXTERNALS:    FDMPN1APS.FOR
C
C ERRORS & LIMITATIONS: Efficiency of this code may be improved by writing in
C               Macro.
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

        CALL vspn1aps (apdata(pn), apdata(u), apdata(v),
     +     apdata(pn1), mx)
        RETURN
        END                                                             ! of routine VSFDMPN1

C===============================================================================

        SUBROUTINE vsfdmruv (g, r, u, v, mx)
        INTEGER g, r, u, v, mx
C-------------------------------------------------------------------------------
C$R     FDM: Recursively calculate u and v. (Simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  APSFDMRUV
C
C FUNCTION:     Refer to FDMRUV.APL
C
C PARAMETERS:   Refer to FDMRUV.APL
C
C COMMON:       /AP120B_MD/ - Main Data (MD) memory buffer for simulator.
C
C CALLED BY:    FDMRUV.APL from APSFDMCAP.FOR from FDMCAP.FOR.
C
C EXTERNALS:    FDMRUVAPS.FOR
C
C ERRORS & LIMITATIONS: Efficiency may be improved by writing in Macro.
C
C REFERENCES:   Refer to FDMRUV.APL
C
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
        CALL vsruvaps (apdata(g), apdata(r), apdata(u), apdata(v),
     +       mx)
        RETURN
        END                                                             ! of routine VSRUVAPS

C===============================================================================

        SUBROUTINE vsruvaps (g, r, u, v, mx)
        REAL    g(mx), r(mx), u(mx), v(mx)
        INTEGER mx
C-------------------------------------------------------------------------------
C$R     FDM: Recursively calculate u and v. (Simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  VSRUVAPS
C
C FUNCTION:     Refer to FDMRUV.APL
C
C PARAMETERS:   Refer to FDMRUV.APL
C
C CALLED BY:    (Subroutine call tree:)
C               - FDM.FOR
C                - FDMLIN.FOR
C                 - FDMCAR.VFC
C                  - APSFDMCAR.FOR
C                   - FDMRUV.APL
C                    - APSFDMRUV.FOR
C                     - FDMRUVAPS.FOR
C
C EXTERNALS:    None
C
C       REVISIONS:
C AUTHOR:  a.j.h.                                     DATE:  4/11/89
C DESCRIPTION:
C    The single vector loop was split into 4 loop for the CRAY. This split
C the vector dependent part of the calculations from the vectorizable parts
C-------------------------------------------------------------------------------
c Mod: PCH, 8 June 2004, Check for divide by zero.  Gamma can become zero!
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

        INTEGER m
        REAL    um1, vm1
C
c****   If you get a divide by zero fault, it probably here.  g = gamma,
c****   which can become zero if the velocity doesn't increase.  I hate
c****   to put this check in, but I can't tell you how much time it took
c****   me to find this quirk.
        DO 50  m = 1,mx
           apscr(m) = 1./g(m) - 2.
           IF( g(m) .EQ. 0. ) THEN
               PRINT *,' FDMIGR fault - divide by zero.'
               PRINT *,' Some velocity is not increasing.'
               STOP
           ENDIF
   50   CONTINUE
C
        um1 = 0.
        DO 100 m = 1, mx
          u(m) = 1. / (apscr(m) - um1)
          um1  = u(m)
  100   CONTINUE
C
        DO 150 m = 1, mx
           apscr(m) = u(m) * r(m)/g(m)
  150   continue
c
        vm1 = 0.
        DO 200 m = 1, mx
          v(m) = -u(m) * vm1 + apscr(m)
          vm1  = v(m)
  200   CONTINUE
c       call dbgap(1)
        RETURN
        END                                                             ! of VSRUVAPS
C
C==============================================================================
C
        SUBROUTINE vspn1aps (pn, u, v, pn1, mx)
        REAL    pn(mx), u(mx), v(mx), pn1(mx)
        INTEGER mx
C-------------------------------------------------------------------------------
C$R     FDM: Recursively calculate the next time slice, P(n+1,j). (Simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  FDMPN1APS
C
C FUNCTION:     Refer to FDMPN1.VFC
C
C PARAMETERS:   Refer to FDMPN1.VFC
C
C CALLED BY:    (Tree of calls to this routine:)
C               - FDMIEX
C                - FDMLIN
C                 - FDMCAR.VFC
C                  - APSFDMCAR.FOR
C                   - FDMPN1.APL
C                    - APSFDMPN1.FOR
C                     - FDMPN1APS.FOR
C
C EXTERNALS:    None
C
C ERRORS & LIMITATIONS: None
C
C REVISIONS:
C AUTHOR: a.j.h.                                     DATE:  4/11/89
C DESCRIPTION:  The single do loop was split into two to allow vectorization
C on the CRAY
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
      INTEGER m
C
      apscr(mx+1) = 0.
c
      DO 100 m = mx, 1, -1
          apscr(m) = v(m) - u(m)*apscr(m+1)
  100 CONTINUE
c
      DO 200 m = mx, 1, -1
          pn1(m) = pn(m) + apscr(m)
  200 CONTINUE
c     call dbgap(2)
      RETURN
      END                                                               ! of routine VSPN1APS
C
C==============================================================================
C
      subroutine setaux(lslice)
      integer lslice
C-------------------------------------------------------------------------------
C   Setaux is responsible for setting up the auxilary AP scratch array APSCR.
C This array holds intermediate results between time slices as well as scratch
C results during calculation.
C   This routine must be called once a Tau step so as to initialize the j+2 time
C slicesat auxscr5/6 to zero.
C
C In
C   lslice : The length of a time slice
C
C  Located at:
C  auxscr1 - Scratch time slice
C  auxscr2 - Scratch time slice
C  auxscr3 - Holds    P(n+1,j+1) - P(n,j+1)
C  auxscr4 - Holds T*(P(n+1,j+1) - P(n,j+1))
C  auxscr5 - Holds    P(n+1,j+2) - P(n,j+2)
C  auxscr6 - Holds T*(P(n+1,j+2) - P(n,j+2))
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

      logical first
      save    first
      data    first /.TRUE./
C
      if (first) then
        first = .FALSE.
        if (lslice.gt.MAXNX) then
          print *,' Size of time slice: ',lslice,
     $            ' exceeds Maximum allowed ', MAXNX
          STOP
        endif
C
        auxscr1 = 1                                                     ! offset to allow for zero pads
        auxscr2 = auxscr1 + lslice
        auxscr3 = auxscr2 + lslice
        auxscr4 = auxscr3 + lslice
        auxscr5 = auxscr4 + lslice
        auxscr6 = auxscr5 + lslice
      endif
C
      do 10 i = auxscr5, auxscr6 + lslice - 1
        apscr(i) = 0.
  10  continue
      return
      end
C
C==============================================================================
C
      subroutine TCONV(a,c,n)
      real    a(0:n-1), c(0:n-1)
      integer n
c-------------------------------------------------------------------------------
c This routines does the 3 pt convolution horizontal convolution (-1,2,-1) for
c FDM. This is the CRAY version which computes it as a single vector loop.
c
c IN:
c   n   : length of data to be convolved
c   a() : array to be convolved.
c OUT
c   c() : output array
c-------------------------------------------------------------------------------
c
      DO 100 ii = 0, n-1
        c(ii) = -a(ii) + 2. * a(ii+1) - a(ii+2)
  100 CONTINUE
      return
      end
C
C==============================================================================
C
      subroutine blkmov(a,c,n)
      integer a,c,n
c-------------------------------------------------------------------------------
c This routine moves data within the AP scratch array.
c   IN
c    a  : location of start of data to shift
c    n  : Number of data to shift
c  OUT
c   c   : Location to shift to
c
c   The CRAY is told to ignore vector dependencies. There should OK for a
c straight shift of the data.
c
c-------------------------------------------------------------------------------
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

CDIR$ IVDEP
      do 100 ii = 0,n-1
        apscr(c+ii) = apscr(a+ii)
  100 continue
      return
      end


text:
This editor can edit this entry and tell us a bit about themselves by clicking the Edit icon.

20100602 19:44:53 nbsp  Welcome to the Wiki. Sorry, the welcome is a little late. It looks like a comment you left on the Davis Computer page has been removed by Users/Khanh. It sparked a bit of discussion at Users/Khanh/Talk. Users/JasonAller

20110106 13:14:40 nbsp Toddplease dont delete peoples comments. If the issue has been resolved, please simply add a comment to your page explaining has been resolved. When you simply remove the comments, it could appear that you have not addressed the issue and could cause a misperception. Thanks Users/PeterBoulay

20110106 21:25:39 nbsp Well then why dont your leave a comment.  She got her $265 back.  I felt that it was no loger relivant.  Besides since that Khanh removed my comment from his page then why cant I be able to remove one.  Also I dont thing that comming from me would be enough as it would be better comming from her.  I dont think that she would be agreeable to leave a comment.  Ive just written her off as a customer.

I had so many problems with a lot of Seagate hard drives that I bought going bad that I stopped using them.  I only use Western Digital.  I dont think that it is possible to get her to understand. Users/ToddJames
   ToddWhy would I leave a comment about a business transaction YOU had? Just leave her a comment about the issue by editing and typing it in right under hers.  Then leave it at that. PeteB

20110113 19:45:25 nbsp Please read Welcome to the wiki/Business Owner, and you will see that the edits you made on the Computer Depot page were not appropriate.  Thus, I restored the page to the way it was.  However, please feel free to add content (information about your business) that is not promotional or an advertisement. Users/CovertProfessor

20110117 12:18:21 nbsp What would you like changed? Users/PeterBoulay

20110119 16:30:06 nbsp Toddplease be aware that Daviswiki cannot be used as a fulltilt advertisement for your businessthe nonprofit status of the Wiki prevents it. You can put up some minimal info and we can try the poster but it will have to be sized appropriately for the page. Users/PeterBoulay

20110119 16:38:45 nbsp Toddthe info you put up was a full blown advertisement with massive detail and the such. The very content of what you put upas I saidviolates the rules about using the Wiki for Advertising. Sorry friend. Users/PeterBoulay

20110119 17:01:56 nbsp Keep in mind you can always view past revisions of any content on the wiki by going to that page and clicking the Info icon next to the title.  Past changes, with a full log of activity, are always visible. Users/JabberWokky Evan JabberWokky Edwards, jw.dw@timewarp.org

20110119 22:13:39 nbsp Im not sure if this answers your question to Pete, since Im not sure what edits/comments/pages are involved, but it might help: As a general rule, users have nearly complete control over content on their own user pages (Users/ToddJames, for instance).  Thats distinct from a page about a person, a business, or anything else on the wiki.  There are occasionally disputes over content on a user page, most often when someone is deliberately being obnoxious by either deleting attempts to communicate with them, or repeatedly making unwanted changes to someone elses user page.  The general practice is to let people control their own page, though, even if theyre being rude about it.

By contrast, people are not free to remove valid comments from nonuser pages (such as a page about a business)particularly not anyone with any sort of direct interest in the business.  That goes for both the owner/employee/whatever of the business, and for competitors.  Sometimes there are problem comments, where someone is just outrageously rude, or makes obviously ridiculous accusations, and those get removed.  Even then, though, just for the sake of appearances, its better if someone who isnt directly involved does the deed. Users/TomGarberson

20110120 12:00:06 nbsp ToddI am one person on this WikiI dont read each and every page. If you can tell me which page specifically you are referring to, Ill be more then happy to look at it. Users/PeterBoulay

20110120 15:42:50 nbsp Toddregarding your concern over Users/Khanh, I am going to request you discuss that matter with Users/JabberWokky as he appears to be more knowledgeable over past issues you have had with that person and their business. Thank You. Users/PeterBoulay

20110120 17:16:54 nbsp Toddyoure switching up on me and confusing me. Previously you specifically mentioned Users/Khanh and now youre changing the issue. On your business page, you deleted negative comments you didnt like from your profilejust because someone says something you dont like it does not mean you can delete it. Users/PeterBoulay

20110120 19:13:26 nbsp Toddas to your concerns about Users/Khanh I will refer you to consult with Users/Jabberwokky as that was a much different situation that I have not had an opportunity to read all the way back on. As to your situation, I have explained why I took the actions I did in an earlier comment about the Wikis NonProfit Status. Please reread itas well, please see Users/TomGarbersons comment earlier. Im going away for a few days and will be unreachableUsers/PeterBoulay

20110802 07:43:36 nbsp Maybe you could http://daviswiki.org/Computer_Repair?actiondiff&version2285&version1284 stop http://daviswiki.org/S%26S_Computer_Repair?actiondiff&version219&version118 messing http://daviswiki.org/Computer_Repair?actiondiff&version2283&version1282 around with info about your competitors. Especially since you have already been asked in the past to stop treating Computer Depot as your own personal http://daviswiki.org/Computer_Depot?actiondiff&version261&version160 advertisement and stop http://daviswiki.org/Computer_Depot?actiondiff&version259&version158 deleting comments you should know better. Thanks. Users/MeggoWaffle

20110802 08:48:49 nbsp Hey, Todd.  You should be aware that because of your ongoing vandalism of the wiki, /Talk somebody has proposed that you be banned.  Even if it doesnt carry through, I would highly recommend that you cease vandalizing and removing content for apparent commercial ends and to advance your business at the cost of your neighbors.  The wiki is not commercial in nature, and although businesses are welcome here, it is critical that everybody have respect for others in Davis and good intentions toward any subject being edited (even if a negative aspect is being presented).  Removing content in an attempt to remove competitors from the community project that is the wiki is especially troubling, and I sincerely urge to to cease such edits. Users/JabberWokky

20110802 08:50:26 nbsp Let me add that I agree completely with what MeggoWaffle and JabberWokky said. Users/CovertProfessor

20110802 20:00:17 nbsp Todd removed the S&S again this evening. I now support a ban on him Users/PeterBoulay

20110802 20:32:59 nbsp Toddaside from your business conflict with S&S, we do not allow people to remove others business listings from the Wiki over this type of an issue. You have been requested SEVERAL times not to do this. Please let this serve as your final warning if you do it again a ban is a very real possibility. Again please leave the Wiki out of your issues with S&S. Thank You Users/PeterBoulay

20110802 20:33:10 nbsp Im sorry you feel that way.  It really isnt appropriate to use the wiki as a weapon.  Please dont vandalize the work of others.  If you feel you cant help it, I would respectfully suggest that you might consider wiki chill pill walking away for awhile until youre calm enough to edit the wiki. Users/JabberWokky Evan JabberWokky Edwards, jw.dw@timewarp.org, (814) 8898845

20110802 21:32:36 nbsp I do have sympathy for your situation, actually.  But it sounds like one of those things that happens in life.  You werent able to take over the property sooner, and they got it first.  It sucks, but thats the way the business world works.  It might be unfair in some sense of the word fairness, but it doesnt sound like anything illegal or even unethical happened.  Unless there is more to the story that youre not telling us.   Users/CovertProfessor

20110802 21:44:08 nbsp Im sorry to hear about the problems youve run into with leasing a location.  Im not sure what deleting the other companys entry is going to do to resolve that, though.  The long and short of it is that this is a community resource that tries to document everything in Davis.  People arent reverting your changes because theyre insensitive to your troubles, but because A) this isnt the place to fight that fight, and B) it wouldnt do any good even if it was the right place.

Seriously, what do you think its going to accomplish? Users/TomGarberson

20110802 22:06:24 nbsp Another thing to keep in mind is that the entry youre vandalizing isnt theirs  its the work of, and owned by the community.  Youre not hurting them, youre lashing out and damaging a shared project that is not theirs.  It sounds like youre obsessing over them (Ive certainly laid awake nights, unable to get a thought out of my head... its part of being human), but youve accidentally tripped across a community effort to document Davis, and are attacking your neighbors instead.  This is not a business listing site.  If you have a legitimate grievance, look at the comments above... people are asking you for details  if its reasonable, the wiki is a perfect place for such things.  Right now it just sounds like they rented a spot before you by coincidence and youre upset you missed out on the spot.  Reasonably upsetting, but unless youre leaving something out it doesnt really seem like cause for vandalizing an open project about the town. Users/JabberWokky Evan JabberWokky Edwards, jw.dw@timewarp.org, (814) 8898845

20110802 22:30:27 nbsp Hi Todd, sorry to hear about your situation. Your complaint really is with the leasing agents for Westlake Plaza, so http://daviswiki.org/Westlake_Plaza is the place to post your story if you feel that will help your business. Users/DonShor

20110803 09:07:59 nbsp I think everyone can understand your emotional reaction to the situation  I know that I can.  And I know how hard it is to get a business up and running, especially in this economy.  Is your plan, though, to focus your energies on trying to drive S&S out of business?  Its none of my business, but that doesnt sound like a very promising strategy.  It also seems, as others have said, that its the leasing agent you should be angry at, not S&S.  I say this out of concern for you, because it sounds like youre having a hard time, and I wouldnt want to see you waste your energies.  Is there another space in Davis that would work for you, even if its not the ideal space that you wanted? Users/CovertProfessor

20110803 17:19:56 nbsp You sound kinda sinister when you talk about this stuff.  Not sure if thats deliberate.  Just a heads up of how its coming across. Users/TomGarberson

20110803 17:20:30 nbsp Ok, I see.  Well, as a businessman Im sure you know that there is good oldfashioned competition to see who can be the best, and then there are more underhanded tactics.  I guess some people saw your deleting the S&S page as being more underhanded.  I hope that youre simply striving to have the best business that you can. Users/CovertProfessor

20110803 20:14:04 nbsp Fine with us.  In case you havent noticed, Davis Wiki does not want to be a business listing site  in fact, it is a nonprofit organization.  It is supposed to be for information only, not advertising. Users/CovertProfessor

20110803 20:19:47 nbsp 20110803 20:11:41   Oh, Im really happy because when I typed computer repair in Google, my listing for my site come up before Davis Wiki. Yea Whoa... Just makes Davis Wiki irrelevant to my business as far as getting new business.

Todd I have been staying out of it, but that comment makes you sound like an ass AND demonstrates that you dont understand the Davis Market.  I can tell you that at least with myself and college students I know, we always turn to the wiki before google searches for finding a business.  I get that you are frustrated but I am sick of your insults about the wiki and how irrelevant it is.  Every business I patronize I discovered through this wiki so you should strive to be a positive influence here. Users/OliviaY
Thats what she said...
Word of mouth is powerful in Davis, as far as generating / keeping clients. Shenanigans like this ensure you dont get referrals from the entrenched people in town... Ive kept silent but Ive read everything on the page I just felt the urge to reaffirm what Olivia says  Daubert

20110804 00:46:31 nbsp I will say no more after this.  You can try to argue the facts that an SEO expert will tell you about peoples habits when using search engines or finding what they are looking for.  You may think what Im saying is ridicules.  Ive learned from the SEO experts and what I say is not just pulling something out of thin air.  Most people that come to this space or otherwise wont even know what Im talking about when I bring up the subject of SEO.

There are 2 types of marketing.  Search, like things like Google, Davis Wiki, etc. are passive marketing and is where people go out and actively search for what they are looking for.  The information is out there for people to find.  Active marketing is where I go out and send them information about my business to their home, business, or a place of business.  Active marketing and SEO will play a much more relevant part as for getting new clients than Davis Wiki.  Sorry you feel this way. Users/ToddJames

20110804 08:24:32 nbsp Say whatever you want about your knowledge of marketing, but those same experts will tell you that you cant overcome the negative perceptions youve begun, and continue to foster, here. Users/Davidlm

20110804 08:53:20 nbsp I through with Davis Wiki.  Im disablingling my account forever! Users/ToddJames

20110804 12:09:55 nbsp Ill agree with David and the others...you dont understand the reach of DavisWiki (and apparently arent willing to reach beyond your misperceptions. To be honest, your lack of ability to spell doesnt help. Good luck in your future. Users/PeterBoulay

20110804 12:22:20 nbsp Young Todd may think hes through. But once you start down the Davis Wiki, forever will it dominate your destiny. Users/ScottMeehleib

20110804 14:15:31 nbsp Hey, at least the vote on banning him didnt have to come to fruition. Users/MeggoWaffle

20110804 14:36:54 nbsp My understanding is the more you search something in Google, the higher itll appear in the search results. Its likely hes getting his business as the first result because hes been searching for his own page so much on Google. Users/TimJ

20130501 20:32:27 nbsp Toddyour pics werent formatting correctly so I reuploaded them and recoded the display info on your page. Nice pics! Users/PeteB


text:
      integer function i8common_entry(list1,list2,n1,n2)

c     returns position of first entry of list1 which can be found on list2

      implicit none
      integer, intent(in) ::
     &     n1, n2
      integer(8), intent(in) ::
     &     list1(n1), list2(n2)

      integer ::
     &     idx, jdx

      i8common_entry = 0

      main_loop: do idx = 1, n1
        do jdx = 1, n2
          if (list1(idx).eq.list2(jdx)) then
            i8common_entry = idx
            exit main_loop
          end if
        end do
      end do main_loop

      return
      end

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


!
!     -------------------------------------------------------------
!      S O O B
!     -------------------------------------------------------------
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
!     OF   SPIN OTHER ORBIT  INTERACTIONS BETWEEN THE ELECTRONS    *
!                                                                  *
!     (n l L S  n l L S ::                 ::n l L S  n l L S )    *
!       1 1 1 1  2 2 2 2                      3 3 3 3  4 4 4 4     *
!                                                                  *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville             October 1996   *
!
!
      SUBROUTINE SOOB(I1, L1, L2, KL1, KL2, AA)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  13:15:20  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: I1
      INTEGER  :: L1
      INTEGER  :: L2
      INTEGER , INTENT(IN) :: KL1
      INTEGER  :: KL2
      REAL(DOUBLE) , INTENT(OUT) :: AA
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IS1, IS2, IS3
!-----------------------------------------------
      AA = ZERO
      IF (KL1 < 0) RETURN
      IF (ITTK(L1,L2,KL2) == 0) RETURN
      IF (KL1 < KL2) THEN
         AA = ONE
         IS1 = 2*KL1 + 1
         IS1 = IS1*(2*KL1 + 3)*(L1 + L2 - KL1)*(KL1 + 1 - L2 + L1)*(KL1 + 1 + &
            L2 - L1)*(KL1 + L1 + L2 + 2)
         IS2 = KL1 + 1
      ELSE IF (KL1 == KL2) THEN
         IF (I1 == 1) THEN
            IF (L1 == L2) THEN
               AA = ONE
               IS1 = KL1*(KL1 + 1)*(2*KL1 + 1)
               IS2 = 1
            ELSE
               IS1 = 2*KL1 + 1
               IS2 = KL1*(KL1 + 1)
               IS3 = L2*(L2 + 1) + KL1*(KL1 + 1) - L1*(L1 + 1)
               AA = DBLE(IS3)
            ENDIF
         ELSE
            AA = TWO
            IS1 = (2*KL1 + 1)*KL1*(KL1 + 1)
            IS2 = 1
         ENDIF
      ELSE
         IF (KL1 < 1) RETURN
         AA = ONE
         IS1 = 2*KL1 + 1
         IS1 = IS1*(2*KL1 - 1)*(L1 + L2 - KL1 + 1)*(KL1 - L2 + L1)*(KL1 + L2 - &
            L1)*(KL1 + L1 + L2 + 1)
         IS2 = KL1
      ENDIF
      AA = AA*DSQRT(DBLE(IS1)/DBLE(IS2))
      RETURN
      END SUBROUTINE SOOB


text:
Address(Bidwell Street) is a residential circular street in East Davis.

 Intersecting Streets

  Donner Avenue
  El Paso Avenue
  Fremont Court
  Austin Street
  Bidwell Place


text:
      SUBROUTINE PKTRQ2 (NTYPE)
C THIS ROUTINE CALCULATES PHASE II OUTPUT FOR PLA4
C
C     NTYPE = 1 TRI-MEMBRANE
C     NTYPE = 2 QUAD-MEMBRANE
C
C     PH1OUT CONTAINS THE FOLLOWING
C     *** NTYPE = 1 ***
C     ELEMENT ID
C     3 SILS
C     5 DUMMY-S
C     3 S ARRAYS EACH 3X3
C
C     *** NTYPE = 2 ***
C     ELEMENT ID
C     4 SILS
C     4 DUMMY-S
C     4 S ARRAYS EACH 3X3
C
      DIMENSION NSIL(4), SI(36)
C
      COMMON /PLA4UV/ IVEC, Z(24)
      COMMON /PLA4ES/ PH1OUT(300)
      COMMON /PLA42S/ STRESS(3),VEC(3),TEMP,DELTA,NSIZE,NPOINT,
     1   DUM(315)
C
      EQUIVALENCE
     1            (NSIL(1),PH1OUT(2))
     2,           (SI(1),PH1OUT(10))
C
C
C                        I=NSIZE
C     STRESS VECTOR = (SUMMATION  (S ) (U ))
C                        I=1        I    I
C
      NSIZE = NTYPE + 2
      DO 20 I = 1,NSIZE
C     POINTER TO DISPLACEMENT VECTOR
      NPOINT = IVEC + NSIL(I) -1
C
      CALL GMMATS( SI(9*I-8),3,3,0,  Z(NPOINT),3,1,0, VEC(1))
C
      DO 30 J=1,3
   30 STRESS(J) = STRESS(J) + VEC(J)
   20 CONTINUE
C
      RETURN
      END


text:
FUNCTION declination(idoy)
!
IMPLICIT NONE
!
INCLUDE 'p1unconv.inc'
!
! Function arguments
!
INTEGER :: idoy
REAL :: declination
!
! Local variables
!
REAL :: b
!
!     + + + purpose + + +
!     this function calculates the declination of the earth with respect
!     the sun based on the day of the year

!     + + + keywords + + +
!     solar declination

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     idoy   - day of year

!     + + + local varaibles + + +

!     + + + local definitions + + +
!     b      - sub calculation (time of year, radians)

!     + + + common blocks + + +

!     + + + end specifications + + +

!     calculate declination angle (dec)
!
b = (360.0/365.0)*(idoy-81.25)*degtorad
declination = 23.45*sin(b)
!
END FUNCTION declination

max_stars_repo_path: Project Documents/Source Code Original/Declination.f90

max_stars_repo_name: USDA-ARS-WMSRU/upgm-standalone

max_issues_repo_name: USDA-ARS-WMSRU/upgm-standalone

max_forks_repo_name: USDA-ARS-WMSRU/upgm-standalone


text:
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! During the discussion of the fix for PR43072, in which unnecessary
! calls to internal PACK/UNPACK were being generated, the following,
! further unnecessary temporaries or PACk/UNPACK were found.
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
! Case 1: Substring encompassing the whole string
subroutine foo2
  implicit none
  external foo
  character(len=20) :: str(2) = '1234567890'
  call foo(str(:)(1:20)) ! This is still not fixed.
end

! Case 2: Contiguous array section
subroutine bar
  implicit none
  external foo
  integer :: a(3,3,3)
  call foo(a(:,:,:)) ! OK, no temporary
  call foo(a(:,:,1)) ! OK, no temporary
  call foo(a(:,2,2)) ! Used unnecessarily a temporary -FIXED
  call foo(a(2,:,1)) ! OK, creates a temporary(1)
end

! Case 3: Stride 1 section.
subroutine foobar
  implicit none
  external foo
  integer :: A(10,10)
  call foo(A(3:7,4)) ! Used unnecessarily a temporary - FIXED
  call foo(A(:,3:7)) ! OK (no temporary)
  call foo(A(1:10,3:7)) ! OK (no temporary)
  call foo(A(4,3:7)) ! temporary OK(2)
  call foo(A(:,3:7:-1)) ! temporary(3) OK because of stride
end
! { dg-final { scan-tree-dump-times "unpack" 3 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
!> Two-phase level-set subroutines.
!!
!! @author Prashant Valluri, Lennon O Naraigh, Iain Bethune,
!! Toni Collis, David Scott, Peter Spelt.
!! @copyright (c) 2013-2015, Prashant Valluri, Lennon O Naraigh,
!! Iain Bethune, Toni Collis, David Scott, Peter Spelt.
!! This program is distributed under the BSD License See LICENSE.txt
!! for details.

module two_phase_levelset

  use levelset
  use tpls_mpi

  implicit none

contains

  ! Note that sz_p = 0 and ez_p = maxn.
  subroutine do_tpls(phi2, phi3, conv0_phi, conv1_phi, conv2_phi, &
       sx, ex, sy, ey,                                            &
       sz_p, ez_p, maxn, ex_max, stride_p_xz, stride_p_yz,        &
       max_iteration_levelset, neighbours, comm2d_quasiperiodic,  &
       height, err2,                                              &
       dx, dz, dt)

    implicit none

    ! Arguments.
    integer, intent(in) :: sx, ex, sy, ey, sz_p, ez_p
    integer, intent(in) :: maxn, ex_max
    integer, intent(in) :: stride_p_xz, stride_p_yz
    integer, intent(in) :: max_iteration_levelset
    integer, intent(in) :: neighbours(6)
    integer, intent(in) :: comm2d_quasiperiodic
    double precision, intent(in) :: dx, dz, dt
    double precision, intent(in) :: height
    double precision, intent(inout) :: err2
    double precision, intent(inout) :: phi2(sx-1:ex+1,sy-1:ey+1,sz_p:ez_p)
    double precision, intent(inout) :: conv0_phi(sx-1:ex+1,sy-1:ey+1,sz_p:ez_p)
    double precision, intent(inout) :: conv1_phi(sx-1:ex+1,sy-1:ey+1,sz_p:ez_p)
    double precision, intent(inout) :: conv2_phi(sx-1:ex+1,sy-1:ey+1,sz_p:ez_p)
    double precision, intent(inout) :: phi3(sx-1:ex+1, sy-1:ey+1, sz_p:ez_p)

    ! Local variables.
    integer :: i, j, k
    integer :: startx, endx
    integer :: iteration_sor
    integer :: istatus_mx(sx-1:ex+1, sy-1:ey+1, sz_p:ez_p)
    double precision :: z_val
    double precision :: D_mx(sx-1:ex+1, sy-1:ey+1, sz_p:ez_p)
    double precision :: sign_mx(sx-1:ex+1, sy-1:ey+1, sz_p:ez_p)
    double precision :: phi_reinit(sx-1:ex+1, sy-1:ey+1, sz_p:ez_p)
    double precision :: RHS_phi(sx-1:ex+1,sy-1:ey+1,sz_p:ez_p)

    !$omp parallel workshare
    !! AB3:
    RHS_phi = (23.d0/12.d0)*conv2_phi - (4.d0/3.d0)*conv1_phi + (5.d0/12.d0)*conv0_phi
    !$omp end parallel workshare

    ! Non-augmented RHS of phi: exchange first-order halos only (default now is with corners).
    call exchange2d(RHS_phi, stride_p_xz, stride_p_yz, neighbours, &
         ex, ey, ez_p, sx, sy, sz_p, comm2d_quasiperiodic)

    !$omp parallel workshare
    ! phi3 and ph2 correspond to finew and fi in the DIM code.
    forall (i = sx:ex, j = sy:ey, k = 1:maxn-1)
       phi3(i, j, k) = phi2(i, j, k) - dt*RHS_phi(i, j, k)
    end forall
    !$omp end parallel workshare

    if(sx==1)then
       do k = 1, maxn-1
          z_val = k*dz - 0.5d0*dz
          phi3(0, sy:ey, k) = (z_val-height)
       end do
    end if
    if(ex==ex_max)then
       do k = 1, maxn-1
          phi3(ex_max+1, sy:ey, k) = phi3(ex_max, sy:ey, k)
       end do
    end if

    if (sx==1) then
       startx = 0
    else
       startx = sx
    endif
    if (ex==ex_max) then
       endx = ex_max+1
    else
       endx = ex
    endif
    phi3(startx:endx, sy:ey, 0) = 2.d0*phi3(startx:endx, sy:ey, 1) - phi3(startx:endx, sy:ey, 2)
    phi3(startx:endx, sy:ey, maxn) = 2.d0*phi3(startx:endx, sy:ey, maxn-1) - phi3(startx:endx, sy:ey, maxn-2)

    ! Non-augmented phi: exchange first-order halos only.
    ! Here, phi3 means the same thing as phi0 in the paper of Smereka and Russo.

    call exchange2d(phi3, stride_p_xz, stride_p_yz, neighbours,  &
         ex, ey, ez_p, sx, sy, sz_p, comm2d_quasiperiodic)

    call get_levelset_status(phi3, D_mx, istatus_mx, sign_mx, sx, ex, sy, ey, maxn, dx)

    phi_reinit=phi3
    do iteration_sor = 1, max_iteration_levelset
       call exchange2d(phi_reinit, stride_p_xz, stride_p_yz, neighbours, &
            ex, ey, ez_p, sx, sy, sz_p, comm2d_quasiperiodic)
       call do_levelset_iteration(phi3, phi_reinit, D_mx, istatus_mx, sign_mx, &
            sx, ex, sy, ey, maxn, ex_max, dx, height, err2)
    end do

    ! Now update phi3 to its redistanced value.
    !$omp parallel workshare
    phi3 = phi_reinit
    !$omp end parallel workshare

  end subroutine do_tpls

end module two_phase_levelset

max_stars_repo_name: Q-Leap-Networks/tpls

max_issues_repo_name: Q-Leap-Networks/tpls

max_forks_repo_name: Q-Leap-Networks/tpls