text:
#include "scalar.fpp"

!=====================================================================!
! One dimensional unsteady tranport physics.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module unsteady_transport_class

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics

  implicit none

  private

  public :: unsteady_transport

  !-------------------------------------------------------------------!
  ! Type that implements first order transport equations
  !-------------------------------------------------------------------!

  type, extends(dynamics) :: unsteady_transport

     type(scalar) :: dx
     type(scalar) :: conv_speed
     type(scalar) :: diff_coeff

   contains

     ! Implement deferred procedures from superclasses
     procedure :: add_residual
     procedure :: add_jacobian
     procedure :: add_jacobian_vector_product => add_jacobian_vector_product
     procedure :: get_initial_condition

     ! Destructor
     final :: destruct

  end type unsteady_transport

  ! Interface to construct the physical system
  interface unsteady_transport
     procedure construct_unsteady_transport
  end interface unsteady_transport

contains

  !===================================================================!
  ! Constructor for unsteady transport physics
  !===================================================================!

  type(unsteady_transport) function construct_unsteady_transport( &
       & diffusion_coeff, convective_velocity, &
       & bounds, npts, sparse) result (this)

    type(scalar), intent(in) :: diffusion_coeff, convective_velocity
    type(scalar), intent(in) :: bounds(2)
    integer     , intent(in) :: npts
    logical     , intent(in) :: sparse

    type(scalar) :: dx
    integer      :: i

    call this % set_description('Unsteady Transport')

    ! Set time order of physical system
    call this % set_differential_order(1)

    ! System parameters
    this % conv_speed = convective_velocity
    this % diff_coeff = diffusion_coeff

    ! Sparse or dense assembly
    this % sparse = sparse

    ! Use FD jacobian or supplied jacobian
    this % approximate_jacobian = .false.

    ! Node locations
    allocate(this % X(3,npts+2)); this % X = 0.0_wp;
    this % dx = (bounds(2) - bounds(1))/dble(npts+1)
    do i = 1, npts + 2
       this % X(1,i) = bounds(1) + dble(i-1)*this % dx
    end do

    ! Set the number of state variables based on spatial
    ! discretization of the governing equations
    call this % set_num_state_vars(npts+2) ! include boundary nodes in system

  end function construct_unsteady_transport

  !===================================================================!
  ! Destructor for unsteady transport physics
  !===================================================================!

  pure subroutine destruct(this)

    type(unsteady_transport), intent(inout) :: this

  end subroutine destruct

  !===================================================================!
  ! Residual assembly at each time step
  !===================================================================!

  pure subroutine add_residual(this, residual, U, X)

    class(unsteady_transport), intent(inout) :: this
    type(scalar)             , intent(inout) :: residual(:)
    type(scalar)             , intent(in)    :: U(:,:)
    type(scalar)             , intent(in)    :: X(:,:)

    ! Locals
    type(scalar) :: a, b, c
    real(wp) :: d, e
    integer :: i

    d = 0.0d0
    e = 0.0d0
    associate(phi=>U(1,:), phidot=> U(2,:), &
         & npts=>this % get_num_state_vars(), &
         & vel=>this % conv_speed, gamma => this % diff_coeff)

    a = -(vel/(2.0_wp*this % dx) + gamma/(this % dx*this % dx))
    b = 2.0_wp*gamma/(this % dx*this % dx)
    c = (vel/(2.0_wp*this % dx) - gamma/(this % dx*this % dx))

    ! Residual with BC applied
    residual(1) = residual(1) + phidot(1) + phi(1) - d
    forall(i = 2 : npts-1)
       residual(i) = residual(i) + phidot(i) + a*phi(i-1) + b*phi(i) + c*phi(i+1)
    end forall
    residual(npts) = residual(npts) + phidot(npts) + phi(npts) - e

  end associate

  end subroutine add_residual

  !===================================================================!
  ! Jacobian assembly at each time step.
  !===================================================================!

  pure subroutine add_jacobian(this, jacobian, coeff, U, X)

    class(unsteady_transport) , intent(inout) :: this
    type(scalar)              , intent(inout) :: jacobian(:,:)
    type(scalar)              , intent(in)    :: coeff(:)
    type(scalar)              , intent(in)    :: U(:,:)
    type(scalar)              , intent(in)    :: X(:,:)

    ! Locals
    type(scalar) :: aa, bb, cc
    integer      :: i, j

    associate(phi=>U(1,:), phidot=> U(2,:), &
         & npts=>this % get_num_state_vars(), &
         & vel=>this % conv_speed, gamma => this % diff_coeff, &
         & alpha=>coeff(1), beta=>coeff(2))

      aa = -(vel/(2.0_wp*this % dx) + gamma/(this % dx*this % dx))
      bb = 2.0_wp*gamma/(this % dx*this % dx)
      cc = (vel/(2.0_wp*this % dx) - gamma/(this % dx*this % dx))

      if (this % sparse .eqv. .true.) then

         jacobian(1,:) = jacobian(1,:) + [0.0d0, beta*1.0d0 + alpha*1.0d0, 0.0d0]
         do concurrent(i = 2:npts-1)
            jacobian(i,:) = jacobian(i,:) + [alpha*aa, beta + alpha*bb, alpha*cc]
         end do
         jacobian(npts,:) = jacobian(npts,:) + [0.0d0, beta*1.0d0 + alpha*1.0d0, 0.0d0]

      else

         jacobian(1,1) = beta*1.0d0 + alpha*1.0d0
         do i = 2, npts-1
            do j = 1, npts
               if (i .eq. j-1) then
                  ! upper diagonal
                  jacobian(i,j) = jacobian(i,j) + alpha*cc
               else if (i .eq. j) then
                  ! diagonal
                  jacobian(i,i) = jacobian(i,j) + beta + alpha*bb
               else if (i .eq. j+1) then
                  ! lower diagonal
                  jacobian(i,j) = jacobian(i,j) + alpha*aa
               else
               end if
            end do
         end do
         jacobian(npts,npts) = beta*1.0d0 + alpha*1.0d0

      end if

    end associate

  end subroutine add_jacobian

  !=====================================================================!
  ! Routine to return the product of jacobian matrix with a compatible
  ! vector.
  !=====================================================================!

  pure subroutine add_jacobian_vector_product(this, pdt, vec, scalars, U, X)

    class(unsteady_transport), intent(inout) :: this
    type(scalar)   , intent(inout) :: pdt(:)
    type(scalar)   , intent(in)    :: vec(:)
    type(scalar)   , intent(in)    :: scalars(:)
    type(scalar)   , intent(in)    :: U(:,:)
    type(scalar)   , intent(in)    :: X(:,:)

    ! Locals
    type(scalar) :: aa, bb, cc
    integer      :: i, j

    associate(phi=>U(1,:), phidot=> U(2,:), &
         & npts=>this % get_num_state_vars(), &
         & vel=>this % conv_speed, gamma => this % diff_coeff, &
         & alpha=>scalars(1), beta=>scalars(2))

      aa = -(vel/(2.0_wp*this % dx) + gamma/(this % dx*this % dx))
      bb = 2.0_wp*gamma/(this % dx*this % dx)
      cc = (vel/(2.0_wp*this % dx) - gamma/(this % dx*this % dx))

      if (this % sparse .eqv. .true.) then

!!$         pdt(1) = pdt(1) + dot_product([beta + alpha*bb, alpha*cc], vec(1:2))
!!$
!!$         !jacobian(1,:) = jacobian(1,:) + [0.0d0, beta + alpha*bb, alpha*cc]
!!$         do concurrent(i = 2 : npts-1)
!!$            !pdt(i) = pdt(i) +
!!$            pdt(i) = pdt(i) + dot_product([alpha*aa, beta + alpha*bb, alpha*cc], vec(i-1:i+1))
!!$            !jacobian(i,:) =  jacobian(i,:) + [alpha*aa, beta + alpha*bb, alpha*cc]
!!$         end do
!!$         !         pdt(npts) = pdt(npts) +
!!$         pdt(npts) = pdt(npts) + dot_product([alpha*aa, beta + alpha*bb], vec(npts-1:npts))
!!$         !jacobian(npts,:) = jacobian(npts,:) + [alpha*aa, beta + alpha*bb, 0.0d0]

      else

!!$         do i = 1, npts
!!$            do j = 1, npts
!!$               if (i .eq. j-1) then
!!$                  ! upper diagonal
!!$                  !jacobian(i,j) = jacobian(i,j) + alpha*cc
!!$               else if (i .eq. j) then
!!$                  ! diagonal
!!$                  !jacobian(i,i) = jacobian(i,j) + beta + alpha*bb
!!$               else if (i .eq. j+1) then
!!$                  ! lower diagonal
!!$                  !jacobian(i,j) = jacobian(i,j) + alpha*aa
!!$               else
!!$               end if
!!$            end do
!!$         end do

      end if

    end associate

  end subroutine add_jacobian_vector_product

  !===================================================================!
  ! Sets the initial condition for use in the integator.
  !===================================================================!

  pure subroutine get_initial_condition(this, U, X)

    class(unsteady_transport), intent(in)    :: this
    type(scalar)             , intent(inout) :: U(:,:)
    type(scalar)             , intent(in)    :: X(:,:)
    type(scalar) :: pi
    integer :: i

    pi = 4.0_wp*atan(1.0_wp)

    associate(phi=>U(1,:), x=>this%X(1,:))

      do i=1,this % get_num_state_vars()
         phi(i) = (0.4_wp*pi)**(-0.5_wp)*exp(-2.5_wp*(x(i)-10.0_wp)*(x(i)-10.0_wp))
      end do

    end associate

  end subroutine get_initial_condition

end module unsteady_transport_class

max_stars_repo_name: komahanb/time-marching-adjoint

max_issues_repo_name: komahanb/diffusion

max_forks_repo_name: komahanb/diffusion


text:
Jump to Timeline #Navigation Navigation

  John Craig Drummond dies

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


! { dg-do compile }
!
! PR 58099: [4.8/4.9 Regression] [F03] over-zealous procedure-pointer error checking
!
! Contributed by Daniel Price <daniel.price@monash.edu>

  implicit none
  procedure(real), pointer :: wfunc

  wfunc => w_cubic

contains

  pure real function w_cubic(q2)
    real, intent(in) :: q2
    w_cubic = 0.
  end function

end


text:
module growtree_c
  implicit none
  private

contains
!
!#########################################################################
!
!*growtree:* the main growing subroutine. Generates a volume-filling tree into a closed surface.
  subroutine grow_tree_c(parent_ne, surface_elems, angle_max, angle_min, branch_fraction, length_limit,&
shortest_length, rotation_limit) bind(C, name="grow_tree_c")

    use arrays,only: dp
    use iso_c_binding, only: c_ptr
    use growtree,only: grow_tree
    implicit none

    integer,intent(in) :: parent_ne
    integer,intent(in) :: surface_elems(:)
    real(dp),intent(in) :: angle_max
    real(dp),intent(in) :: angle_min
    real(dp),intent(in) :: branch_fraction
    real(dp),intent(in) :: length_limit
    real(dp),intent(in) :: shortest_length
    real(dp),intent(in) :: rotation_limit

#if defined _WIN32 && defined __INTEL_COMPILER
    call so_grow_tree(parent_ne, surface_elems, angle_max, angle_min, branch_fraction, length_limit,&
shortest_length, rotation_limit)
#else
    call grow_tree(parent_ne, surface_elems, angle_max, angle_min, branch_fraction, length_limit,&
shortest_length, rotation_limit)
#endif

  end subroutine grow_tree_c

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

end module growtree_c

max_stars_repo_name: AnnikaGspandl/lungsim

max_issues_repo_name: AnnikaGspandl/lungsim

max_forks_repo_name: AnnikaGspandl/lungsim


text:
Pakpour Family Law is a law firm started by Davis attorney Users/BrianPakpour Brian Pakpour, offering legal assistance to those seeking to resolve typical family law matters, including:

 Divorce, Legal Separation or Nullity
 Samesex Marriage Dissolution
 Child Custody
 Visitation
 Child Support
 Spousal Support
 Property Distribution (including retirements)
 Grandparent Rights
 Legal Guardianships
 Sexual Assault and Domestic Violence Center Domestic Violence Restraining Orders, and
 Modifications of any of these orders.

Pakpour Family Law offers a free initial consultation to new clients. The firm will represent clients in Yolo County, https://sacwiki.org/Sacramento_County?actionshow&redirectSacramento+County&wikidavis Sacramento County, and Placer County Family Courts.

  http://members.calbar.ca.gov/fal/Member/Detail/288960 CalBar Profile — Admitted to the bar on 20130220.

Up the creek without a paddle? Check out the Legal Services page.


text:
C    %W% %G%
C****************************************************************
C
C   	File: ext_bus.f
C
C   	Purpose: Write bus, continuation bus, X-data, and PQ-curve
C                data onto saved NETWORK_DATA file savfil.
C                                                                      *
C       Input parameters:
C
C             savfil   - the logical unit opened
C             dialect  - a character string (BPA, WSCC, WSCC1, WSCC2,
C                        PTI) denoting the dialect of the WSCC record.
c             lenrec   - an integer 80 or 120 denoting the output
C                        record size
c             ratcod   - a character string denoting extended
c                        line ratings used (E- EXTENDED, N-NOMINAL,
C                        or M-MINIMUM)
c             sections - a character string <null> or "PSEUDOBUSES"
c                        denoting how line sections are to be
c                        represented
c             type_e   - a character string <null> or "SYMMETRIC"
c                        denoting how assymetric type E-branches are
c                        to be represented
C
C   	Author: Walt Powell            Date: 13 January 1993
C   	Called by: savenetd.f
C
C****************************************************************
C
      integer function ext_bus ( savfil, dialect, lenrec, ratcod,
     &                           sections, type_e )

      character*(*) dialect, ratcod, sections, type_e
      integer savfil, lenrec

      include 'ipfinc/parametr.inc'

      include 'ipfinc/blank.inc'
      include 'ipfinc/alpha.inc'
      include 'ipfinc/area.inc'
      include 'ipfinc/bus.inc'
      include 'ipfinc/cbus.inc'
      include 'ipfinc/branch.inc'
      include 'ipfinc/com007.inc'
      include 'ipfinc/pqcurves.inc'
      include 'ipfinc/prt.inc'
      include 'ipfinc/xdata.inc'
      include 'ipfinc/pseudo_b.inc'
      include 'ipfinc/pti_data.inc'

      common /code_ovfg/ code_ovfg
      character code_ovfg*3
c
c     Set code_ovfg = 'ON' to replace '****' with '+XEX' values
c
      character xbuf*120, cbtype*1, cbown*3, bctbl_fld(20,7)*10,
     &          ybuf*120, code*10
      integer total1, total2, total3, total4, total5, ptr, chkovflo,
     &        status, bctbl_index(7), bctbl_format(7), firstxstr,
     &        oldptr, ptrx, fndpsptr, new_bsnm, bus_type
      real temp(20)
      logical flag, pseudo_sections, ior, type_e_branches
      complex*16 v(2), a(2), y(2,2), zxx, yxx, vxx

      data bctbl_index / 2, 3, 4, 5, 6, 11, 12 /
      data bctbl_format / 5, 5, 4, 4, 5, 5, 5 /
c
c     *******************************************************
c     set up pointers to any P/Q curve data
c
c     Store X-data pointer in busxdtptr() and P/Q curve
c     data pointer in buspqptr()
c
      ext_bus = 0
      num_pseudo = 0
      ntot_pseudo = 0
      pseudo_sections = (firstxstr(sections, 'PSEUDO*') .ne. 0 .and.
     &                   dialect .ne. 'WSCC1' .and.
     &                   dialect .ne. 'WSCC2')
      type_e_branches = (firstxstr(type_e, 'SYMMETRIC*') .ne. 0 .and.
     &                   dialect .ne. 'WSCC1' .and.
     &                   dialect .ne. 'WSCC2')

      do i = 1, HASHSIZE
        htable(i) = 0
      enddo

      do i = 1, MAX_PSEUDO
        nextptr(i) = 0
        pseudo(1,i) = 0
      enddo

      if (.not. pq_flag) then
         do nb = 1, ntot
            buspqptr(nb) = 0
         enddo

         do i = 1, numcurv
            ieq = pqbusptr(i)
            if (ieq .gt. 0) buspqptr(ieq) = i
         enddo
         pq_flag = .true.
      endif

      if (.not. xdt_flag) then
         do nb = 1, ntot
            busxdtptr(nb)  = 0
         enddo
         do i = 1, kxtot
            ptr = xdata(1,i)
            if (ptr .gt. 0) busxdtptr(ptr) = i
         enddo
         xdt_flag = .true.
      endif

C     Select default for calculation of %var support for remote control

      if ( dialect(1:3) .eq. 'BPA' ) then
         call bcdopt( 'DEFAULT',0.0 )
         code_ovfg = 'OFF'
      else if ( dialect(1:4) .eq. 'WSCC' ) then
         call bcdopt( 'CALCULATE',0.0 )
         code_ovfg = 'OFF'
      else if ( dialect(1:3) .eq. 'PTI' ) then
         call bcdopt( 'CALCULATE',0.0 )
         code_ovfg = 'ON'
      else
         code_ovfg = 'OFF'
      endif

      total1 = 0       ! Count of buses extracted
      total2 = 0       ! Count of + buses extracted
      total3 = 0       ! Count of X buses extracted
      total4 = 0       ! Count of PQ-curve data extracted
      total5 = 0       ! Count of Pseuod buses in passive node sections

      do ib = 1, ntot_alf
         nb = alf2inp(ib)
         bus_type = kbsdta(1,nb)
         flag = .false.
         if (dialect .eq. 'BPA' ) then
            call bcdbus(nb, xbuf)
            if (lenrec .eq. 80) then
               write (savfil, '(a)') xbuf(1:80)
            else
               kt = inp2opt(nb)
               vmag = dsqrt (e(kt) ** 2 + f(kt) ** 2)
               vang = 57.2957795 * atan2 (f(kt), e(kt))
               qk = qnetu(kt)
               call allocq (nb, qk, qgen, qgnmax, qgnmin, qld, totcap,
     &                      usecap, totrek, userek, unsked, qerr)
               write (xbuf(82:120), fmt='(f10.7, f12.6, 2f8.1)')
     &           vmag, vang, qgen, userek+usecap
               write (savfil, '(a)') xbuf(1:120)
            endif
            total1 = total1 + 1
            ptr = kbsdta(15,nb)
            do while (ptr .gt. 0)
               call bcdcbs(ptr, xbuf)
c
c              Check overflow of + bus data fields
c
               if (index (xbuf(21:57), '****') .ne. 0) then
                  ybuf = xbuf
                  maxnum = 0
                  do i = 1, 7
                     j = bctbl_index(i)
                     status = chkovflo (bctbl(j,ptr), bctbl_format(i),
     &                                  0, num, bctbl_fld(1,i))
                     do j = num+1, 20
                        bctbl_fld(j,i) = ' '
                     enddo
                     maxnum = max (num, maxnum)
                  enddo
c
c                 Create individual + records
c
                  do i = 1, maxnum
                     write (ybuf(5:6), '(i2)') i
                     ybuf(21:25) = bctbl_fld(i,1)
                     ybuf(26:30) = bctbl_fld(i,2)
                     ybuf(31:34) = bctbl_fld(i,3)
                     ybuf(35:38) = bctbl_fld(i,4)
                     ybuf(43:47) = bctbl_fld(i,5)
                     ybuf(48:52) = bctbl_fld(i,6)
                     ybuf(53:57) = bctbl_fld(i,7)
                     write (savfil, '(a)') ybuf(1:80)
                     total2 = total2 + 1
                  enddo
               else
                  write (savfil, '(a)') xbuf(1:80)
                  total2 = total2 + 1
               endif
               ptr = bctbl_nxt(ptr)
            enddo
            ptr = busxdtptr(nb)
            if (ptr .gt. 0) then
               call bcdxdt(ptr, xbuf)
               write (savfil, '(a)') xbuf(1:80)
               total3 = total3 + 1
            endif
            kpq = buspqptr(nb)
            if (kpq .gt. 0) then
               call bcdqpd(kpq, xbuf)
               write (savfil, '(a)') xbuf(1:lenrec)
               call bcdqxd(kpq, xbuf)
               write (savfil, '(a)') xbuf(1:lenrec)
               call bcdqnd(kpq, xbuf)
               write (savfil, '(a)') xbuf(1:lenrec)
               total4 = total4 + 1
            endif

         else
c
c           Temporarily consolidate + bus quantities with bus
c           data, extract the aggregated bus record, and restore
c           the original bus record.
c
            do i = 1, 16
               temp(i) = busdta(i,nb)
            enddo
c
c           Consolidate  "+"  records onto bus record
c           exception:
c               +A INT   records are kept separate
c                        under the WSCC1 and WSCC2 options.
c
            flag = .false.
            ptr = kbsdta(15,nb)
            totsuscp = 0.0
            do while (ptr .gt. 0)
               call getchr (1, cbtype, kbctbl(8,ptr))
               call getchr (3, cbown, kbctbl(10,ptr))
               if ((dialect .eq. 'WSCC1' .or. dialect .eq. 'WSCC2')
     &              .and. cbtype .eq. 'A'
     &              .and. cbown .eq. 'INT')  then
                  flag = .true.
               else
                  if (cbtype .eq. 'A') then
                     totsuscp = totsuscp + bctbl(5,ptr)
                  endif
                  flag = .true.
                  do i = 2, 5
                     busdta(i+1,nb) = busdta(i+1,nb) + bctbl(i,ptr)
                  enddo
                  busdta(8,nb) = busdta(8,nb) + bctbl(6,ptr)
                  busdta(9,nb) = busdta(9,nb) + bctbl(11,ptr)
                  busdta(10,nb) = busdta(10,nb) + bctbl(12,ptr)
               endif
               ptr = bctbl_nxt(ptr)
            enddo
c
c           Implement WSCC variants into bus
c
            call bcdbus(nb, xbuf)
            call bus_edt (xbuf, dialect, totsuscp)
            if (dialect(1:4) .eq. 'WSCC') then
               xbuf(15:18) = pti_name(nb)
               if ((bus_type .eq. 8 .or. bus_type .eq. 11) .and.
     &              xbuf(66:73) .ne. ' ') then
                  basekv = ftn_atof (xbuf(74:77))
                  mb = kbsdta(13,nb)
                  if (mb .ne. 0) then
                    xbuf(74:77) = pti_name(mb)
                  endif
               else if (bus_type .eq. 5 .or.
     &                 (bus_type .eq. 12 .and. xbuf(51:58) .ne. ' '))
     &           then
                  basekv = ftn_atof (xbuf(59:62))
                  mb = kbsdta(9,nb)
                  if (mb .ne. 0) then
                    xbuf(59:62) = pti_name(mb)
                  endif
               endif
            endif
            if (lenrec .eq. 80) then
               write (savfil, '(a)') xbuf(1:80)
            else
               kt = inp2opt(nb)
               vmag = dsqrt (e(kt) ** 2 + f(kt) ** 2)
               vang = 57.2957795 * atan2 (f(kt), e(kt))
               qk = qnetu(kt)
               call allocq (nb, qk, qgen, qgnmax, qgnmin, qld, totcap,
     &                      usecap, totrek, userek, unsked, qerr)
               write (xbuf(82:120), fmt='(f10.7, f12.6, 2f8.1)')
     &           vmag, vang, qgen, userek+usecap
               write (savfil, '(a)') xbuf(1:120)
            endif
            do i = 1, 16
               busdta(i,nb) = temp(i)
            enddo
            if (flag) then
               ptr = kbsdta(15,nb)
               do while (ptr .gt. 0)
                  call getchr (1, cbtype, kbctbl(8,ptr))
                  call getchr (3, cbown, kbctbl(10,ptr))
                  if ((dialect .eq. 'WSCC1' .or. dialect .eq. 'WSCC2')
     &                .and. cbtype .eq. 'A'
     &                .and. cbown .eq. 'INT')  then
                     call bcdcbs (ptr, xbuf)
                     xbuf(15:18) = pti_name(nb)
                     write (savfil, '(a)') xbuf(1:80)
                     total2 = total2 + 1
                  endif
                 ptr = bctbl_nxt(ptr)
               enddo
            endif

            ptr = busxdtptr(nb)
            if (dialect(1:4) .eq. 'WSCC' .and. kbsdta(1,nb) .ne. 11)
     &        ptr = 0
            if (ptr .gt. 0) then
               call bcdxdt(ptr, xbuf)
               xbuf(15:18) = pti_name(nb)
               if (xbuf(21:28) .ne. ' ') then
                  basekv = ftn_atof (xbuf(29:32))
                  mb = xdata(2,ptr)
                  if (mb .ne. 0) then
                    xbuf(29:32) = pti_name(mb)
                  endif
               endif
               write (savfil, '(a)') xbuf(1:80)
               total3 = total3 + 1
            endif
         endif
      enddo
c
c     First pass - check for sections = 'PSEUDOBUSES' option
c
      if (pseudo_sections) then
         do ib = 1, ntot_alf
            nb = alf2inp(ib)
            flag = .false.
            ptr = kbsdta(16,nb)
            do while (ptr .gt. 0)
               if (brtype(ptr) .eq. 1) then
                  nbr = iabs (brnch_ptr(ptr))
                  call getchr (3, cbown, kbrnch(3,nbr))
                  if (brnch_ptr(ptr) .gt. 0) then
                     ior = ((brnch_ptr(ptr) .gt. 0 .and.
     &                       kbrnch(15, nbr) .eq. 0) .or.
     &                      (brnch_ptr(ptr) .lt. 0 .and.
     &                       kbrnch(15, nbr) .gt. 0))
                     num_sec = 0
                     kt = inp2opt(nb)
                     mt = inp2opt(ky(ptr))
c
c                    Compute 2-port quantities for equivalent
c
                     v(1) = dcmplx (e(kt), f(kt))
                     v(2) = dcmplx (e(mt), f(mt))
                     call pieqiv(ptr, y, kerr)
                     do i = 1, 2
                        a(i) = dcmplx(0.0,0.0)
                        do j = 1, 2
                           a(i) = a(i) + y(i,j) * v(j)
                        enddo
                     enddo
                     num = 0
                     lastpseudo = 0
                     base1 = base(nb)
                     base2 = base1
                     oldptr = ptr
                     ptr = brnch_nxt(ptr)
                     do while (ptr .gt. 0 .and.
     &                         ky(ptr) .eq. ky(oldptr) .and.
     &                         brid(ptr) .eq. brid(oldptr))
c
c                       Compute 2-port quantities for each section
c
                        num_sec = num_sec + 1
                        call pieqiv(ptr, y, kerr)

                        if (num_sec .gt. 1) then
                          v(1) = v(2)
                          a(1) = -a(2)
                        endif
                        v(2) = (a(1) - y(1,1) * v(1)) / y(1,2)
                        a(2) = y(2,1) * v(1) + y(2,2) * v(2)

                        base1 = base2
                        if (brtype(ptr) .eq. 5 .or.
     &                      brtype(ptr) .eq. 6) base2 = base(ky(ptr))
                        lastbus = num
                        nbr = iabs (brnch_ptr(ptr))
                        call getchr (3, cbown, kbrnch(3,nbr))
                        numpsu = fndpsptr (ptr)
                        if (numpsu .eq. 0) then
                           write ( errbuf(1), 10000) MAX_PSEUDO
10000                      format (' More than ', i4,
     &  ' pseudo buses added using SECTIONS=PSEUDOBUSES option')
                           write ( errbuf(2), 10010) bus(nb), base(nb)
10010                      format (' Overflow occurred at bus ', a8,
     &                       f6.1)
                           call prterx ('W', 2)
                           go to 900
                        else if (numpsu .lt. 0) then
c
c                          -numpsu flags a new entity at num_pseudo
c
                           numpsu = -numpsu
                           if (num_sec .eq. 1) then
                              pseudo(2,numpsu) = 1
                              pseudo(3,numpsu) = kx(ptr)
                           else
                              pseudo(2,numpsu) = 2
                              pseudo(3,numpsu) = pseudo(4,lastpseudo)
                           endif
                           ptrx = brnch_nxt(ptr)
                           if (ptrx .gt. 0 .and.
     &                         ky(ptrx) .eq. ky(oldptr) .and.
     &                         brid(ptrx) .eq. brid(oldptr)) then
c
c                             Find unique pseudo-bus name
c
                              num = new_bsnm (bus(nb), base2, '&',
     &                                        ntot+ntot_pseudo+1)
                              if (num .eq. 0) go to 900
                              pti_name(num) = code (base2, 4, 0)
                              ntot_pseudo = ntot_pseudo + 1
                              pseudo(4,numpsu) = num
                              kbsdta(1,num) = 1
                              do i = 2, 16
                                 kbsdta(i,num) = 0
                              enddo
                              inp2opt(num) = num
                              e(num) = dreal (v(2))
                              f(num) = dimag (v(2))
                              ntypu(num) = 1
                              if (ior) then
                                 zone(num) = zone(ky(ptr))
                                 jarzn(num) = jarzn(ky(ptr))
                                 owner(num) = cbown
                              else
                                 zone(num) = zone(nb)
                                 jarzn(num) = jarzn(nb)
                                 if (lastbus .gt. 0)
     &                              owner(lastbus) = cbown
                              endif
                           else
                              pseudo(2,numpsu) = 3
                              pseudo(4,numpsu) = ky(ptr)
                              if (.not. ior .and. lastbus .gt. 0) then
                                 owner(lastbus) = cbown
                              endif
                           endif
                        else
                           write ( errbuf(1), 10000) MAX_PSEUDO
                           write ( errbuf(2), 10010) bus(nb), base(nb)
                           call prterx ('W', 2)
                           go to 900
                        endif
                        ptr = brnch_nxt(ptr)
                        lastpseudo = numpsu
                     enddo
c
c                    Nullify pseudo-bus feature for single sections
c
                     if (num_sec .eq. 1) then
                        pseudo(2,numpsu) = 0
                     endif
                  else
                     ptr = brnch_nxt(ptr)
                  endif
               else
                  ptr = brnch_nxt(ptr)
               endif
            enddo
         enddo
      endif
c
c     Second pass - Replace assymmetric type E branches with type L
C     branches.
c
      if (type_e_branches) then
         do ib = 1, ntot_alf
            nb = alf2inp(ib)
            flag = .false.
            ptr = kbsdta(16,nb)
            do while (ptr .gt. 0)
               if (brtype(ptr) .eq. 1 .and.
     &             brnch_ptr(ptr) .gt. 0) then
                  nbr = iabs (brnch_ptr(ptr))
                  call getchr (3, cbown, kbrnch(3,nbr))

                  kt = inp2opt(nb)
                  mt = inp2opt(ky(ptr))
c
c                 Compute 2-port quantities for equivalent
c
                  v(1) = dcmplx (e(kt), f(kt))
                  v(2) = dcmplx (e(mt), f(mt))
                  call pieqiv(ptr, y, kerr)
                  do i = 1, 2
                    a(i) = dcmplx(0.0,0.0)
                    do j = 1, 2
                      a(i) = a(i) + y(i,j) * v(j)
                    enddo
                  enddo

                  num_sec = 0
                  kt = inp2opt(nb)
                  mt = inp2opt(ky(ptr))
                  base1 = base(nb)
                  base2 = base1

                  num = 0
                  oldptr = ptr
                  ptr = brnch_nxt(ptr)
                  do while (ptr .gt. 0 .and.
     &                      ky(ptr) .eq. ky(oldptr) .and.
     &                      brid(ptr) .eq. brid(oldptr))
                     nbr = iabs (brnch_ptr(ptr))
c
c                    Compute 2-port quantities for each section
c
                     num_sec = num_sec + 1
                     call pieqiv(ptr, y, kerr)

                     if (num_sec .gt. 1) then
                       v(1) = v(2)
                       a(1) = -a(2)
                     endif
                     v(2) = (a(1) - y(1,1) * v(1)) / y(1,2)
                     a(2) = y(2,1) * v(1) + y(2,2) * v(2)

                     base1 = base2
                     if (brtype(ptr) .eq. 5 .or. brtype(ptr) .eq. 6)
     &                  base2 = base(ky(ptr))
                     if (brtype(ptr) .eq. 8 .and.
     &                   brnch(8,nbr) .ne. brnch(10,nbr) .and.
     &                   brnch(5,nbr) .gt. 0.0002) then
                        numpsu = fndpsptr (ptr)
                        if (numpsu .eq. 0) then
                           write ( errbuf(1), 10000) MAX_PSEUDO
                           write ( errbuf(2), 10010) bus(nb), base(nb)
                           call prterx ('W', 2)
                           go to 900
                        else if (numpsu .lt. 0) then
c
c                          -numpsu flags a new entity at num_pseudo
c
                           numpsu = -numpsu
                           pseudo(2,numpsu) = 0
                        endif
                        b1 = brnch(8,nbr)
                        b2 = brnch(10,nbr)
                        zxx = cmplx (0.0, 0.0001)
                        yxx = cmplx (0.0, 0.5 * (amin1(b1, b2) -
     &                                           amax1(b1, b2)))
                        if ((b1 .gt. b2 .and. brnch_ptr(ptr) .gt. 0)
     &                 .or. (b1 .lt. b2 .and. brnch_ptr(ptr) .lt. 0))
     &                     then
                           pseudo(5,numpsu) = 2
                           nbx = pseudo(4,numpsu)
                           if (nbx .eq. 0) nbx = ky(ptr)
c
c                          Compute pseudo-bus voltage
c
                           y(2,1) = -cmplx (1.0, 0.0) / zxx
                           y(2,2) = yxx - y(2,1)
                           vxx = (a(2) - v(2)*y(2,2)) / y(2,1)
                        else
                           pseudo(5,numpsu) = 1
                           nbx = pseudo(3,numpsu)
                           if (nbx .eq. 0) nbx = kx(ptr)
c
c                          Compute pseudo-bus voltage
c
                           y(1,2) = -cmplx (1.0, 0.0) / zxx
                           y(1,1) = yxx - y(1,2)
                           vxx = (a(1) - v(1)*y(1,1)) / y(1,2)
                        endif
c
c                       Find unique pseudo-bus name
c
                        num = new_bsnm (bus(nbx), base2, '@',
     &                                  ntot+ntot_pseudo+1)
                        if (num .eq. 0) go to 900
                        pti_name(num) = code (base2, 4, 0)
                        ntot_pseudo = ntot_pseudo + 1
                        pseudo(6,numpsu) = num
                        kbsdta(1,num) = 1
                        do i = 2, 16
                           kbsdta(i,num) = 0
                        enddo
                        inp2opt(num) = num

                        e(num) = dreal (vxx)
                        f(num) = dimag (vxx)
                        ntypu(num) = 1
                        zone(num) = zone(nbx)
                        jarzn(num) = jarzn(nbx)
                        owner(num) = owner(nbx)
                     endif
                     ptr = brnch_nxt(ptr)
                  enddo
               else if (brtype(ptr) .eq. 8 .and.
     &                  brnch_ptr(ptr) .gt. 0) then
                  nbr = iabs (brnch_ptr(ptr))
                  if (brnch(8,nbr) .ne. brnch(10,nbr) .and.
     &                brnch(5,nbr) .gt. 0.0002) then
                     numpsu = fndpsptr (ptr)
                     if (numpsu .eq. 0) then
                        write ( errbuf(1), 10000) MAX_PSEUDO
                        write ( errbuf(2), 10010) bus(nb), base(nb)
                        call prterx ('W', 2)
                        go to 900
                     else if (numpsu .lt. 0) then
c
c                       -numpsu flags a new entity at num_pseudo
c
                        numpsu = -numpsu
                        pseudo(2,numpsu) = 0
                     endif
                     b1 = brnch(8,nbr)
                     b2 = brnch(10,nbr)
                     zxx = cmplx (0.0, 0.0001)
                     yxx = cmplx (0.0, 0.5 * (amin1(b1, b2) -
     &                                        amax1(b1, b2)))
c
c                    Compute 2-port quantities for equivalent
c
                     kt = inp2opt(nb)
                     mt = inp2opt(ky(ptr))
                     v(1) = dcmplx (e(kt), f(kt))
                     v(2) = dcmplx (e(mt), f(mt))
                     call pieqiv(ptr, y, kerr)
                     do i = 1, 2
                       a(i) = dcmplx(0.0,0.0)
                       do j = 1, 2
                         a(i) = a(i) + y(i,j) * v(j)
                       enddo
                     enddo
                     if (b1 .gt. b2) then
                        pseudo(5,numpsu) = 2
                        nbx = pseudo(4,numpsu)
                        if (nbx .eq. 0) nbx = ky(ptr)
c
c                       Compute pseudo-bus voltage
c
                        y(2,1) = -cmplx (1.0, 0.0) / zxx
                        y(2,2) = yxx - y(2,1)
                        vxx = (a(2) - v(2)*y(2,2)) / y(2,1)
                     else
                        pseudo(5,numpsu) = 1
                        nbx = pseudo(3,numpsu)
                        if (nbx .eq. 0) nbx = kx(ptr)
c
c                       Compute pseudo-bus voltage
c
                        y(1,2) = -cmplx (1.0, 0.0) / zxx
                        y(1,1) = yxx - y(1,2)
                        vxx = (a(1) - v(1)*y(1,1)) / y(1,2)
                     endif
c
c                    Find unique pseudo-bus name
c
                     num = new_bsnm (bus(nbx), base(nbx), '@',
     &                               ntot+ntot_pseudo+1)
                     if (num .eq. 0) go to 900
                     ntot_pseudo = ntot_pseudo + 1
                     pseudo(6,numpsu) = num
                     kbsdta(1,num) = 1
                     do i = 2, 16
                        kbsdta(i,num) = 0
                     enddo
                     inp2opt(num) = num
                     e(num) = dreal (vxx)
                     f(num) = dimag (vxx)
                     ntypu(num) = 1
                     zone(num) = zone(nbx)
                     jarzn(num) = jarzn(nbx)
                     owner(num) = owner(nbx)
                  endif
                  ptr = brnch_nxt(ptr)
               else
                  ptr = brnch_nxt(ptr)
               endif
            enddo
         enddo
      endif

      if (num_pseudo .gt. 0) then
         xbuf = '.'
         write (savfil, '(a)') xbuf(1:80)
         xbuf = '.  Pseudo-buses follow'
         write (savfil, '(a)') xbuf(1:80)
         xbuf = '.'
         write (savfil, '(a)') xbuf(1:80)
         do i = 1, num_pseudo
            last = 3
            do while (last .le. 6)
               nb = pseudo(last,i)
               if (nb .gt. ntot) then
                  call bcdbus(nb, xbuf)
                  xbuf(15:18) = pti_name(nb)
                  if (lenrec .eq. 80) then
                     write (savfil, '(a)') xbuf(1:80)
                  else
                     kt = inp2opt(nb)
                     vmag = dsqrt (e(kt) ** 2 + f(kt) ** 2)
                     vang = 57.2957795 * atan2 (f(kt), e(kt))
                     write (xbuf(82:120), fmt='(f10.7, 1x, f12.7)')
     &                 vmag, vang
                     write (savfil, '(a)') xbuf(1:120)
                  endif
               endif
               if (last .eq. 3) then
                  last = 6
               else
                  last = 7
               endif
            enddo
         enddo
         total5 = num_pseudo
         xbuf = '.'
         write (savfil, '(a)') xbuf(1:80)
         xbuf = '.  End of Pseudo-buses'
         write (savfil, '(a)') xbuf(1:80)
         xbuf = '.'
         write (savfil, '(a)') xbuf(1:80)
      endif

  900 write ( errbuf(1), 910) total1, total2, total3, total4, total5
  910 format (' Total bus records extracted:', i5, ' B, ', i4, ' +, ',
     & i4, ' QP ', i4, 1x, i4, ' and ', i4, ' Pseudobuses')
      call prterx ('I', 1)

      ext_bus = total1 + total2 + total3 + total4 + total5

      return
      end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
The Sacramento Day Trippers is a travel organization that travels all around Northern California to wineries, festivals, local events, theater, and more. There are several sub divisions that include NYC trip and International Trips. The business is hosted through meetup and is owned and operated by Grady O Bryant .

Day Trippin’
Meet Sacramento’s King of Day Trips: Grady O’Bryant

Grady O’Bryant never flies solo. Part travel junkie, part entrepreneur, part social butterfly, he’s helped thousands of people get out of their houses and their shells to explore new places together.

“I just love getting people together for travel. Everything’s more fun as a group. Plus, with someone else handling the details, people can just relax and enjoy the journey.”

Always on the lookout for new ways to help people enjoy themselves, O’Bryant created Sacramento Day Trippers in 2008 to take advantage of the city’s proximity to “the good life”. The group’s 2,100 members have enjoyed tours of wine country, San Francisco, Lake Tahoe, Half Moon Bay and other locations in Northern California. He recently took over 130 members on a day trip to the Monterey Bay Aquarium. Upcoming trips include festivals such as the Gilroy Garlic Festival and Fillmore Jazz Festival, Oakland A’s and Raiders games, plays in San Francisco, a Lake Tahoe Cruise, and more.

Sacramento Wine & Nightlife Tours and Sacramento Day Trippers sacdaytrips.com are wildly popular with people wanting to relax while someone else does the driving, and are an economical way to do so, thanks to great group rates.  Trips are adultonly, giving those with or without children some quality downtime with their peers, and tend to attract a nice mix of folks in the 25 to 65 yearold age range.

http://www.meetup.com/sacdaytripscom/photos/

PICTURES

2012 Calender Upcoming Events

Trip to See “Mamma Mia” in San Francisco
Sat, Feb 25 2012 11:00a.m.  9:00p.m.

A Day in the Bay  S.F. Adventure Trip
Sat, Mar 10 2012 7:30a.m.  9:00p.m.

Trip to the St Patricks Day Parade & Festival in S.F.
Sat, Mar 17 2012 9:30a.m.  6:00p.m.

Pier 39 and Alcatraz Evening Tour
Sat, Mar 24 2012 1:00p.m.  11:00p.m.

Day Trip to Monterey Bay Aquarium & Cannery Row
Sat, Apr 7 2012 7:30a.m.  8:30p.m.

Day Trip to Safari West & Sonoma Town Square
Sat, Apr 14 2012 7:30a.m.  5:30p.m.

Lake Tahoe Cruise onboard the Dixie Queen
Sat, Apr 21 2012 8:00a.m.  7:00p.m.

Day Trip to Yosemite National Park cohosted by Discover Yosemite
Sat, May 12 2012 6:00a.m.  9:00p.m.

An Intimate Evening with Garrett Perkins in Wine Country
Sat, Jul 14 2012 1:30p.m.  9:00p.m.

Trip to See “LES MISÉRABLES” in San Francisco
Sat, Jul 21 2012 11:00a.m.  9:00p.m.

Trip to Blues & Bones Festival in Angel Camp (from Sacramento)
Sat, Jul 21 2012 11:30a.m.  11:30p.m.

Trip to the Gilroy Garlic Festival
Sat, Jul 28 2012 8:00a.m.  6:30p.m.


text:
Describe Users/Mohammad here.

Hi Mohammad. welcome to the wiki! please consider the importance of using your realname and please remember to preview as it is your friend

 Users/StevenDaubert

20100126 23:28:36 nbsp Clarification: were talking RealName here, not your real name

hope that clears these murky wiki waters for you Users/StevenDaubert


text:
      subroutine qq_tchan_htq_dk(p,msq)
      implicit none
c---Matrix element squared averaged over initial colors and spins
c     u(-p1)+b(p2)->h(p3,p4)+t(nu(p5)+e(p6)+b(p7))+d(p8)
      include 'ewcouple.f'
      include 'constants.f'
      include 'hdecaymode.f'
      include 'masses.f'
      include 'nwz.f'
      include 'zprods_com.f'
      integer nu,eta,e5
      double precision p(mxpart,4),q(mxpart,4),q5Deta,s34,hdecay,
     & msq(-nf:nf,-nf:nf),msqgamgam,fac,tpropsq,
     & b_u,u_b,db_b,b_db,d_bb,ub_bb,bb_d,bb_ub,ubhtdsqdk
       double complex mdecaymb(2,2),mdecay

C   Deal with Higgs decay
      s34=(p(3,4)+p(4,4))**2-(p(3,1)+p(4,1))**2
     &   -(p(3,2)+p(4,2))**2-(p(3,3)+p(4,3))**2
      if (hdecaymode == 'tlta') then
          call htautaudecay(p,3,4,hdecay)
      elseif (hdecaymode == 'bqba') then
          call hbbdecay(p,3,4,hdecay)
      elseif (hdecaymode == 'gaga') then
          hdecay=msqgamgam(hmass)
      else
      write(6,*) 'Unimplemented process'
      stop
      endif
      hdecay=hdecay/((s34-hmass**2)**2+(hmass*hwidth)**2)

c --  Deal with top decay
c --  tdecay assumes a massive b, hence 4 polarizations -- we only need one
      mb=0d0
      if (nwz .eq. 1) then
      call tdecay(p,5,6,7,mdecaymb)
      mdecay=mdecaymb(1,1)
      elseif (nwz .eq. -1) then
      call adecay(p,5,6,7,mdecaymb)
      mdecay=mdecaymb(2,2)
      endif
c -- now assign momenta for undecayed top
      q(1,:)=p(1,:)
      q(2,:)=p(2,:)
      q(3,:)=p(3,:)
      q(4,:)=p(4,:)
      q(5,:)=p(5,:)+p(6,:)+p(7,:)
      q(6,:)=p(8,:)

      eta=6
      q5Deta=q(5,4)*p(eta,4)
     & -q(5,1)*p(eta,1)-q(5,2)*p(eta,2)-q(5,3)*p(eta,3)

      e5=7
      do nu=1,4
C   store rescaled electron momentum in position e5
      q(e5,nu)=mt**2*p(eta,nu)/(2d0*q5Deta)
C   Construct demassified momentum for q(5,:)
C   using rescaled electron momentum q(e5,:)
      q(5,nu)=q(5,nu)-q(e5,nu)
      enddo
      tpropsq=1d0/(mt*twidth)**2

      fac=xn**2*aveqq*gwsq**5*hdecay*tpropsq

C -- zero all components of msq
      msq(:,:)=0d0

      if (nwz .eq. +1) then
      call spinoru(7,q,za,zb)

      u_b=ubhtdsqdk(1,2,3,4,5,6,e5,mdecay)*fac
      db_b=ubhtdsqdk(6,2,3,4,5,1,e5,mdecay)*fac
      b_u=ubhtdsqdk(2,1,3,4,5,6,e5,mdecay)*fac
      b_db=ubhtdsqdk(6,1,3,4,5,2,e5,mdecay)*fac

      msq(-1,+5)=db_b
      msq(-3,+5)=db_b
      msq(+2,+5)=u_b
      msq(+4,+5)=u_b
      msq(+5,-1)=b_db
      msq(+5,-3)=b_db
      msq(+5,+2)=b_u
      msq(+5,+4)=b_u

      elseif(nwz .eq. -1) then
      call spinoru(7,q,zb,za)

      d_bb=ubhtdsqdk(1,2,4,3,5,6,e5,mdecay)*fac
      ub_bb=ubhtdsqdk(6,2,4,3,5,1,e5,mdecay)*fac
      bb_d=ubhtdsqdk(2,1,4,3,5,6,e5,mdecay)*fac
      bb_ub=ubhtdsqdk(6,1,4,3,5,2,e5,mdecay)*fac

      msq(+1,-5)=d_bb
      msq(+3,-5)=d_bb
      msq(-2,-5)=ub_bb
      msq(-4,-5)=ub_bb

      msq(-5,+1)=bb_d
      msq(-5,+3)=bb_d
      msq(-5,-2)=bb_ub
      msq(-5,-4)=bb_ub

      endif
      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
C
C
C  Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
C
C  This program is free software; you can redistribute it and/or modify it
C  under the terms of version 2.1 of the GNU Lesser General Public License
C  as published by the Free Software Foundation.
C
C  This program is distributed in the hope that it would be useful, but
C  WITHOUT ANY WARRANTY; without even the implied warranty of
C  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
C
C  Further, this software is distributed without any warranty that it is
C  free of the rightful claim of any third person regarding infringement
C  or the like.  Any license provided herein, whether implied or
C  otherwise, applies only to this software file.  Patent licenses, if
C  any, provided herein do not apply to combinations of this program with
C  other software, or any other product whatsoever.
C
C  You should have received a copy of the GNU Lesser General Public
C  License along with this program; if not, write the Free Software
C  Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307,
C  USA.
C
C  Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
C  Mountain View, CA 94043, or:
C
C  http://www.sgi.com
C
C  For further information regarding this notice, see:
C
C  http://oss.sgi.com/projects/GenInfo/NoticeExplan
C
C

      subroutine whenmeq(n,array,inc,target,index,nmatch,mask,nright)
      integer n, array(1), inc, target, index(1), nmatch, mask, nright
      integer i, k
*
*     -------------
*     USM What Line
*     -------------
CDIR$ ID "@(#) libu/sci/c2/whenmeq.f	92.0	10/08/98 14:57:41"
*
      nmatch = 0
      if ( n .le. 0 ) return
      if ( inc .ge. 0 ) then
         i = 1
      else
         i = 1 - (n-1)*inc
      end if
      do 100 k = 1, n
         if ( and(mask,shiftr(array(i),nright)) .eq. target ) then
            nmatch = nmatch + 1
            index(nmatch) = k
         end if
         i = i + inc
100   continue
      return
      end

max_stars_repo_name: sharugupta/OpenUH

max_issues_repo_name: sharugupta/OpenUH

max_forks_repo_name: sharugupta/OpenUH


text:
!
! ACCoeff_Binary_IO
!
! Module containing routines to read and write Binary format
! ACCoeff data files.
!
!
! CREATION HISTORY:
!       Written by:  Paul van Delst, 08-Jun-2007
!                    paul.vandelst@noaa.gov
!

MODULE ACCoeff_Binary_IO

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module use
  USE Type_Kinds         , ONLY: Long, Double
  USE File_Utility       , ONLY: File_Open, File_Exists
  USE Message_Handler    , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message
  USE Binary_File_Utility, ONLY: Open_Binary_File
  USE ACCoeff_Define     , ONLY: ACCoeff_type          , &
                                 ACCoeff_Associated    , &
                                 ACCoeff_Destroy       , &
                                 ACCoeff_Create        , &
                                 ACCoeff_ValidRelease  , &
                                 ACCoeff_Info
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: ACCoeff_Binary_InquireFile
  PUBLIC :: ACCoeff_Binary_ReadFile
  PUBLIC :: ACCoeff_Binary_WriteFile
  PUBLIC :: ACCoeff_Binary_IOVersion

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PRIVATE, PARAMETER :: MODULE_VERSION_ID = &
    '$Id: ACCoeff_Binary_IO.f90,v 1.1 2013/04/07 22:56:26 jguo Exp $'
  CHARACTER(*), PARAMETER :: WRITE_ERROR_STATUS = 'DELETE'
  ! Default message length
  INTEGER, PARAMETER :: ML = 256

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       ACCoeff_Binary_InquireFile
!
! PURPOSE:
!       Function to inquire a Binary format ACCoeff file.
!
! CALLING SEQUENCE:
!       Error_Status = ACCoeff_Binary_InquireFile( &
!                        Filename                           , &
!                        n_FOVs           = n_FOVs          , &
!                        n_Channels       = n_Channels      , &
!                        Release          = Release         , &
!                        Version          = Version         , &
!                        Sensor_Id        = Sensor_Id       , &
!                        WMO_Satellite_Id = WMO_Satellite_Id, &
!                        WMO_Sensor_Id    = WMO_Sensor_Id     )
!
! INPUTS:
!       Filename:           Character string specifying the name of the binary
!                           antenna correction data file to inquire.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(IN)
!
! OPTIONAL OUTPUTS:
!       n_FOVs:             Number of sensor fields-of-view (FOVs).
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(IN)
!
!       n_Channels:         Number of sensor channels.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(IN)
!
!       Release:            The data/file release number. Used to check
!                           for data/software mismatch.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Version:            The data/file version number. Used for
!                           purposes only in identifying the dataset for
!                           a particular release.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Sensor_Id:          Character string sensor/platform identifier.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       WMO_Satellite_Id:   The WMO code used to identify satellite platforms.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       WMO_Sensor_Id:      The WMO code used to identify sensors.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:       The return value is an integer defining the error
!                           status. The error codes are defined in the
!                           Message_Handler module.
!                           If == SUCCESS the file inquire was successful
!                              == FAILURE an unrecoverable error occurred.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION ACCoeff_Binary_InquireFile( &
    Filename        , &  ! Input
    n_FOVs          , &  ! Optional output
    n_Channels      , &  ! Optional output
    Release         , &  ! Optional Output
    Version         , &  ! Optional Output
    Sensor_Id       , &  ! Optional Output
    WMO_Satellite_Id, &  ! Optional Output
    WMO_Sensor_Id   ) &  ! Optional Output
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: Filename
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_FOVs
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_Channels
    INTEGER     , OPTIONAL, INTENT(OUT) :: Release
    INTEGER     , OPTIONAL, INTENT(OUT) :: Version
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: Sensor_Id
    INTEGER     , OPTIONAL, INTENT(OUT) :: WMO_Satellite_Id
    INTEGER     , OPTIONAL, INTENT(OUT) :: WMO_Sensor_Id
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'ACCoeff_InquireFile(Binary)'
    ! Function variables
    CHARACTER(ML) :: msg
    INTEGER :: io_stat
    INTEGER :: fid
    TYPE(ACCoeff_type) :: ACCoeff

    ! Setup
    err_stat = SUCCESS
    ! ...Check that the file exists
    IF ( .NOT. File_Exists( Filename ) ) THEN
      msg = 'File '//TRIM(Filename)//' not found.'
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Open the file
    err_stat = Open_Binary_File( Filename, fid )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error opening '//TRIM(Filename)
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Read the release and version
    READ( fid,IOSTAT=io_stat ) ACCoeff%Release, ACCoeff%Version
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading Release/Version. IOSTAT = ",i0)' ) io_stat
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Read the dimensions
    READ( fid, IOSTAT=io_stat ) &
      ACCoeff%n_FOVs    , &
      ACCoeff%n_Channels
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading dimension values from ",a,". IOSTAT = ",i0)' ) &
             TRIM(Filename), io_stat
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Read the sensor ids
    READ( fid, IOSTAT=io_stat ) &
      ACCoeff%Sensor_Id       , &
      ACCoeff%WMO_Satellite_Id, &
      ACCoeff%WMO_Sensor_Id
    IF ( io_stat /= 0 ) THEN
      WRITE( msg, '("Error reading sensor information from ",a,". IOSTAT = ",i0)' ) &
             TRIM(Filename), io_stat
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Close the file
    CLOSE( fid, IOSTAT=io_stat )
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error closing ",a,". IOSTAT = ",i0)' ) TRIM(Filename), io_stat
      CALL Inquire_Cleanup(); RETURN
    END IF

    ! Assign the return arguments
    IF ( PRESENT(n_FOVs          ) ) n_FOVs           = ACCoeff%n_FOVs
    IF ( PRESENT(n_Channels      ) ) n_Channels       = ACCoeff%n_Channels
    IF ( PRESENT(Release         ) ) Release          = ACCoeff%Release
    IF ( PRESENT(Version         ) ) Version          = ACCoeff%Version
    IF ( PRESENT(Sensor_Id       ) ) Sensor_Id        = TRIM(ACCoeff%Sensor_Id)
    IF ( PRESENT(WMO_Satellite_Id) ) WMO_Satellite_Id = ACCoeff%WMO_Satellite_Id
    IF ( PRESENT(WMO_Sensor_Id   ) ) WMO_Sensor_Id    = ACCoeff%WMO_Sensor_Id

  CONTAINS

    SUBROUTINE Inquire_CleanUp()
      ! Close file if necessary
      IF ( File_Open(fid) ) THEN
        CLOSE( fid,IOSTAT=io_stat )
        IF ( io_stat /= 0 ) &
          msg = TRIM(msg)//'; Error closing input file during error cleanup'
      END IF
      ! Set error status and print error message
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME, msg, err_stat )
    END SUBROUTINE Inquire_CleanUp

  END FUNCTION ACCoeff_Binary_InquireFile

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       ACCoeff_Binary_ReadFile
!
! PURPOSE:
!       Function to read ACCoeff object files in Binary format.
!
! CALLING SEQUENCE:
!       Error_Status = ACCoeff_Binary_ReadFile( &
!                        Filename           , &
!                        ACCoeff            , &
!                        No_Close = No_Close, &
!                        Quiet    = Quiet     )
!
! INPUTS:
!       Filename:       Character string specifying the name of a
!                       ACCoeff format data file to read.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       ACCoeff:        ACCoeff object containing the antenna correction
!                       coefficient data.
!                       UNITS:      N/A
!                       TYPE:       ACCoeff_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       No_Close:       Set this logical argument to *NOT* close the datafile
!                       upon exiting this routine. This option is required if
!                       the ACCoeff data is embedded within another file
!                       (e.g. SpcCoeff file.)
!                       If == .FALSE., File is closed upon function exit [DEFAULT].
!                          == .TRUE.,  File is NOT closed upon function exit
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Quiet:          Set this logical argument to suppress INFORMATION
!                       messages being printed to stdout
!                       If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                          == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status.
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS, the file read was successful
!                          == FAILURE, an unrecoverable error occurred.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION ACCoeff_Binary_ReadFile( &
    Filename, &  ! Input
    ACCoeff , &  ! Output
    No_Close, &  ! Optional input
    Quiet   , &  ! Optional input
    Debug   ) &  ! Optional input (Debug output control)
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),       INTENT(IN)  :: Filename
    TYPE(ACCoeff_type), INTENT(OUT) :: ACCoeff
    LOGICAL,  OPTIONAL, INTENT(IN)  :: No_Close
    LOGICAL,  OPTIONAL, INTENT(IN)  :: Quiet
    LOGICAL,  OPTIONAL, INTENT(IN)  :: Debug
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'ACCoeff_ReadFile(Binary)'
    ! Function variables
    CHARACTER(ML) :: msg
    LOGICAL :: close_file
    LOGICAL :: noisy
    INTEGER :: io_stat
    INTEGER :: fid
    TYPE(ACCoeff_type) :: dummy

    ! Setup
    err_stat = SUCCESS
    ! ...Check No_Close argument
    close_file = .TRUE.
    IF ( PRESENT(No_Close) ) close_file = .NOT. No_Close
    ! ...Check Quiet argument
    noisy = .TRUE.
    IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet
    ! ...Override Quiet settings if debug set.
    IF ( PRESENT(Debug) ) THEN
      IF ( Debug ) noisy = .TRUE.
    END IF

    ! Check if the file is open.
    IF ( File_Open( Filename ) ) THEN
      ! ...Inquire for the logical unit number
      INQUIRE( FILE=Filename, NUMBER=fid )
      ! ...Ensure it's valid
      IF ( fid < 0 ) THEN
        msg = 'Error inquiring '//TRIM(Filename)//' for its FileID'
        CALL Read_CleanUp(); RETURN
      END IF
    ELSE
      ! ...Open the file if it exists
      IF ( File_Exists( Filename ) ) THEN
        err_stat = Open_Binary_File( Filename, fid )
        IF ( err_Stat /= SUCCESS ) THEN
          msg = 'Error opening '//TRIM(Filename)
          CALL Read_CleanUp(); RETURN
        END IF
      ELSE
        msg = 'File '//TRIM(Filename)//' not found.'
        CALL Read_CleanUp(); RETURN
      END IF
    END IF

    ! Read and check the release and version
    READ( fid,IOSTAT=io_stat ) dummy%Release, dummy%Version
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading Release/Version. IOSTAT = ",i0)' ) io_stat
      CALL Read_Cleanup(); RETURN
    END IF
    IF ( .NOT. ACCoeff_ValidRelease( dummy ) ) THEN
      msg = 'ACCoeff Release check failed.'
      CALL Read_Cleanup(); RETURN
    END IF

    ! Read the antenna correction coefficient data
    ! ...Read the dimensions
    READ( fid, IOSTAT=io_stat ) dummy%n_FOVs    , &
                                dummy%n_Channels
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading data dimensions. IOSTAT = ",i0)' ) io_stat
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Allocate the object
    CALL ACCoeff_Create( ACCoeff         , &
                         dummy%n_FOVs    , &
                         dummy%n_Channels  )
    IF ( .NOT. ACCoeff_Associated( ACCoeff ) ) THEN
      msg = 'ACCoeff object allocation failed.'
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Read the sensor ids
    READ( fid, IOSTAT=io_stat ) ACCoeff%Sensor_Id       , &
                                ACCoeff%WMO_Satellite_Id, &
                                ACCoeff%WMO_Sensor_Id
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading sensor ids. IOSTAT = ",i0)' ) io_stat
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Read the sensor channels
    READ( fid, IOSTAT=io_stat ) ACCoeff%Sensor_Channel
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading sensor channels. IOSTAT = ",i0)' ) io_stat
      CALL Read_Cleanup(); RETURN
    END IF
    ! ...Read the antenna correction coefficients
    READ( fid, IOSTAT=io_stat ) ACCoeff%A_earth   , &
                                ACCoeff%A_space   , &
                                ACCoeff%A_platform
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error reading antenna correction coefficients. IOSTAT = ",i0)' ) io_stat
      CALL Read_Cleanup(); RETURN
    END IF

    ! Explicitly assign the version number
    ACCoeff%Version = dummy%Version

    ! Close the file
    IF ( close_file ) THEN
      CLOSE( fid,IOSTAT=io_stat )
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error closing ",a,". IOSTAT = ",i0)' ) TRIM(Filename), io_stat
        CALL Read_Cleanup(); RETURN
      END IF
    END IF

    ! Output an info message
     IF ( noisy ) THEN
       CALL ACCoeff_Info( ACCoeff, msg )
       CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION )
     END IF

   CONTAINS

     SUBROUTINE Read_CleanUp()
       IF ( File_Open(Filename) ) THEN
         CLOSE( fid,IOSTAT=io_stat )
         IF ( io_stat /= 0 ) &
           msg = TRIM(msg)//'; Error closing input file during error cleanup.'
       END IF
       CALL ACCoeff_Destroy( ACCoeff )
       err_stat = FAILURE
       CALL Display_Message( ROUTINE_NAME, msg, err_stat )
     END SUBROUTINE Read_CleanUp

  END FUNCTION ACCoeff_Binary_ReadFile

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       ACCoeff_Binary_WriteFile
!
! PURPOSE:
!       Function to write ACCoeff object files in Binary format.
!
! CALLING SEQUENCE:
!       Error_Status = ACCoeff_Binary_WriteFile( &
!                        Filename           , &
!                        ACCoeff            , &
!                        No_Close = No_Close, &
!                        Quiet    = Quiet     )
!
! INPUTS:
!       Filename:       Character string specifying the name of a
!                       ACCoeff format data file to read.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       ACCoeff:        ACCoeff object containing the antenna correction
!                       coefficient data.
!                       UNITS:      N/A
!                       TYPE:       ACCoeff_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       No_Close:       Set this logical argument to *NOT* close the datafile
!                       upon exiting this routine. This option is required if
!                       the ACCoeff data is to be embedded within another file
!                       (e.g. SpcCoeff file.)
!                       If == .FALSE., File is closed upon function exit [DEFAULT].
!                          == .TRUE.,  File is NOT closed upon function exit
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Quiet:          Set this logical argument to suppress INFORMATION
!                       messages being printed to stdout
!                       If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                          == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status.
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS, the file write was successful
!                          == FAILURE, an unrecoverable error occurred.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION ACCoeff_Binary_WriteFile( &
    Filename, &  ! Input
    ACCoeff , &  ! Input
    No_Close, &  ! Optional input
    Quiet   , &  ! Optional input
    Debug   ) &  ! Optional input (Debug output control)
  RESULT( err_stat )
    ! Arguments
    CHARACTER(*),       INTENT(IN) :: Filename
    TYPE(ACCoeff_type), INTENT(IN) :: ACCoeff
    LOGICAL,  OPTIONAL, INTENT(IN) :: No_Close
    LOGICAL,  OPTIONAL, INTENT(IN) :: Quiet
    LOGICAL,  OPTIONAL, INTENT(IN) :: Debug
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'ACCoeff_WriteFile(Binary)'
    ! Function variables
    CHARACTER(ML) :: msg
    LOGICAL :: close_file
    LOGICAL :: noisy
    INTEGER :: io_stat
    INTEGER :: fid

    ! Setup
    err_stat = SUCCESS
    ! ...Check No_Close argument
    close_file = .TRUE.
    IF ( PRESENT(No_Close) ) close_file = .NOT. No_Close
    ! ...Check Quiet argument
    noisy = .TRUE.
    IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet
    ! ...Override Quiet settings if debug set.
    IF ( PRESENT(Debug) ) THEN
      IF ( Debug ) noisy = .TRUE.
    END IF
    ! ...Check there is data to write
    IF ( .NOT. ACCoeff_Associated( ACCoeff ) ) THEN
      msg = 'ACCoeff object is empty.'
      CALL Write_Cleanup(); RETURN
    END IF

    ! Check if the file is open.
    IF ( File_Open( FileName ) ) THEN
      ! ...Inquire for the logical unit number
      INQUIRE( FILE=Filename, NUMBER=fid )
      ! ...Ensure it's valid
      IF ( fid < 0 ) THEN
        msg = 'Error inquiring '//TRIM(Filename)//' for its FileID'
        CALL Write_CleanUp(); RETURN
      END IF
    ELSE
      ! ...Open the file for output
      err_stat = Open_Binary_File( Filename, fid, For_Output=.TRUE. )
      IF ( err_Stat /= SUCCESS ) THEN
        msg = 'Error opening '//TRIM(Filename)
        CALL Write_CleanUp(); RETURN
      END IF
    END IF

    ! Write the release and version
    WRITE( fid,IOSTAT=io_stat ) ACCoeff%Release, ACCoeff%Version
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error writing Release/Version. IOSTAT = ",i0)' ) io_stat
      CALL Write_Cleanup(); RETURN
    END IF

    ! Write the antenna correction coefficient data
    ! ...Write the dimensions
    WRITE( fid, IOSTAT=io_stat ) ACCoeff%n_FOVs    , &
                                 ACCoeff%n_Channels
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error writing data dimensions. IOSTAT = ",i0)' ) io_stat
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Write the sensor info
    WRITE( fid, IOSTAT=io_stat ) ACCoeff%Sensor_Id       , &
                                 ACCoeff%WMO_Satellite_Id, &
                                 ACCoeff%WMO_Sensor_Id
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error writing sensor ids. IOSTAT = ",i0)' ) io_stat
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Write the sensor channels
    WRITE( fid, IOSTAT=io_stat ) ACCoeff%Sensor_Channel
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error writing sensor channels. IOSTAT = ",i0)' ) io_stat
      CALL Write_Cleanup(); RETURN
    END IF
    ! ...Write the antenna correction coefficients
    WRITE( fid, IOSTAT=io_stat ) ACCoeff%A_earth   , &
                                 ACCoeff%A_space   , &
                                 ACCoeff%A_platform
    IF ( io_stat /= 0 ) THEN
      WRITE( msg,'("Error writing antenna correction coefficients. IOSTAT = ",i0)' ) io_stat
      CALL Write_Cleanup(); RETURN
    END IF

    ! Close the file
    IF ( close_file ) THEN
      CLOSE( fid,IOSTAT=io_stat )
      IF ( io_stat /= 0 ) THEN
        WRITE( msg,'("Error closing ",a,". IOSTAT = ",i0)' ) TRIM(Filename), io_stat
        CALL Write_Cleanup(); RETURN
      END IF
    END IF

    ! Output an info message
     IF ( noisy ) THEN
       CALL ACCoeff_Info( ACCoeff, msg )
       CALL Display_Message( ROUTINE_NAME, 'FILE: '//TRIM(Filename)//'; '//TRIM(msg), INFORMATION )
     END IF

   CONTAINS

     SUBROUTINE Write_Cleanup()
       IF ( File_Open(Filename) ) THEN
         CLOSE( fid,IOSTAT=io_stat )
         IF ( io_stat /= 0 ) &
           msg = TRIM(msg)//'; Error closing input file during error cleanup.'
       END IF
       err_stat = FAILURE
       CALL Display_Message( ROUTINE_NAME, msg, err_stat )
     END SUBROUTINE Write_Cleanup

  END FUNCTION ACCoeff_Binary_WriteFile

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       ACCoeff_Binary_IOVersion
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL ACCoeff_Binary_IOVersion( Id )
!
! OUTPUT ARGUMENTS:
!       Id:   Character string containing the version Id information
!             for the module.
!             UNITS:      N/A
!             TYPE:       CHARACTER(*)
!             DIMENSION:  Scalar
!             ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE ACCoeff_Binary_IOVersion( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    Id = MODULE_VERSION_ID
  END SUBROUTINE ACCoeff_Binary_IOVersion

END MODULE ACCoeff_Binary_IO

max_stars_repo_name: GEOS-ESM/AeroApps

max_issues_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


program foo
  integer :: i, j, k
  integer :: a(10), c(10)
  k = 2
  a(:) = 0
  call test1
  call test2
  do i = 1, 10
    if (a(i) .ne. 10 * i) call abort
  end do
  !$omp parallel do reduction (+:c)
  do i = 1, 10
    c = c + a
  end do
  do i = 1, 10
    if (c(i) .ne. 10 * a(i)) call abort
  end do
  !$omp parallel do lastprivate (j)
  do j = 1, 10, k
  end do
  if (j .ne. 11) call abort
contains
  subroutine test1
    integer :: i
    integer :: b(10)
    do i = 1, 10
      b(i) = i
    end do
    c(:) = 0
    !$omp parallel do reduction (+:a)
    do i = 1, 10
      a = a + b
    end do
  end subroutine test1
  subroutine test2
    !$omp parallel do lastprivate (j)
    do j = 1, 10, k
    end do
    if (j .ne. 11) call abort
  end subroutine test2
end program foo


text:
Pizza Guys is a large chain and one of the lowerpriced Pizza places in Davis. Discounts and freebies Coupons come in the junk mail mail all the time. You can get a free 2liter bottle of Pepsi or 8 oz. ice cream if you pickup any pizza order. They also Delivery deliver for $2.95 (delivery fee was increased from $2 on 20110219).

The deals involving the garlic bread are definitely worth it. The area of the garlic bread is 1/2 that of the large pie, and with an Pizza: FSI Calculations FSI of 56.7, it has 58% as much cheese as a large pie.

If you have a Super Saver Card, you can get  an XLarge 3topping pizza for $12.99 and a second XLarge 3topping pizza of equal or lesser value for $9.99.  They also offer an AAA Discount.

Apparently it is the Davis pizza location of choice for San Francisco 49ers coach Jim Harbaugh, who was spotted here Saturday, July 16th.

They now have gluten free option for custom 12 pizza.

Pizza Guys in 3D

A 3D view of Pizza Guys can be seen in Google Earth. This building was modeled by Curtis Computing Solutions James Curtis Computing Solutions. To view this model now you can click http://sketchup.google.com/3dwarehouse/download?mid357c246b2ab6eb1175aadd7c43c4aa50&rtypks&fntaqueria_davis&ctypother&ts1279768187000 Here.

Pizza Guys/Reviews from 2005 2005 Reviews ~ 12 Reviews/Comments
Pizza Guys/Reviews from 2006 & 2007 2006/2007 Reviews ~ 10 Reviews/Comments
Pizza Guys/Reviews from 2008 2008 Reviews ~ 11 Reviews/Comments

20090318 13:18:09 nbsp Good food, but stingy on the toppings. Users/strawberry

20090524 17:19:37 nbsp Best Pizza in Davis!! Users/aaron.smith

20090527 22:21:25 nbsp So, I used to think that Steves had the best cheezy garlic breadsticks, but then I tried Pizza Guys. THEY ARE FREAKING AMAZING. I love the cheese and garlic sauce, and they always serve it with ranch (but will give you marinara if you ask). I did have a problem with delivery once, because they couldnt find my apartment, then called me and said they were here, only to call back and say they werent. I ended up having to walk away from my actual apartment to the front of the complex, only to find out they came to my door anyways after I asked them to stay at the sign. However, they did make it up to me by giving me extra breadsticks (although, I found it peculiar that they already premade them like they KNEW they were gonna screw up).

Also, they have great deals a lot of the time. But if you go for pickup, make sure you bring mace, cuz that neighborhood is shaaaady. Users/BrookeB

20090724 11:37:11 nbsp Update on my last posting (because I eat Pizza Guys way too much) they really are stingy on the toppings, and they seem to take a long time to make pizzas. Ive called and it sounded really dead in the store, and theyve told me its going to take 30 minutes or so, and then when we go pick up the pizza (and the store is dead) its not even ready yet. They did a big oops on one of our orders, but they gave us a whole new pizza on top of the messed up one for free (but that could just be because some of the employees are Russian and I was hanging with a Russian fellow).

All in all, its cheap and pretty tasty so Ill eat it, but Lamppost and even Papa Johns are better. Users/Kiran

20100325 16:34:02 nbsp This pizza is simply low quality. It is greasy but not in a good way. The crust on just a one topping is soggy and the sauce lacks flavor. The service is friendly but that is the only good thing coming from this pizza joint. Users/JoeRandom

20100519 10:03:25 nbsp What are you talking about.. this place is SO expensive! 15.99 for specialty medium _  wow Users/JKx788

20100627 00:05:30 nbsp This place is awesome if you use their coupons. Most of the time you can just mention the coupon and not actually have one in hand, you can also print the coupons from their website. The pizza is not the best in town, but it isnt bad. I just got an extra large pepperoni delivered for 15.49. They are open late enough and are usually pretty fast if its not the weekend. My order was 45 min on a sat night. Tip the drivers a couple bucks if you can, they deserve it. Users/reviewaskew

20100822 21:29:48 nbsp Fair pizza, commensurate with the price which is lower than the better pizza places in Davis. You definitely want to use a coupon and they are not hard to find. It seems like I get one mailed to me every week. There is one thing about Pizza Guys in Davis that really pisses me off ....... for pickup orders, as a matter of standard operating procedure, they are always 5  25 minutes later than they tell you. Just got back from there and it went better than usual. On the phone the guy said it would be 10  15 minutes, Im pretty sure this is his boiler plate statement. It was 23 minutes. I use the place because with a coupon it is inexpensive as fair pizzas in Davis go, and it is one block from my house. When I care to spend a little more and get the best pizza in town I get one from Steves Pizza. Some other long time Davis residents may disagree with me and say Woodstocks Pizza is the best. However, those places are rather expensive.   Users/djnurco
  I would actually say Village Bakery, but Im with you on convenience.  Users/WesP

HORRIBLE SERVICE  do not go here!  First, they are late on my pickup time, then they give me the wrong pizza, the wrong pasta. When I call the place to get my pizza replaced, they put me on hold for ten minutes, and the asshole manager Vova tells me to chill out when I complain about being forgotten on the phone, and then bitches when I ask him to redeliver the pizza. These guys are dicks.  Could even get acknowledged at the counter. GO ELSEWHERE. Users/DavisLurker

20101028 09:29:03 nbsp Having moved on from Davis, I will say that I really miss being able to order a pesto pizza.  I always have to make my own if I want a pesto pizza, which defeats the idea of pizza as convenience food for a crowd (and I dont particularly like most pizza anyway). Users/JabberWokky

20110220 08:58:01 nbsp The Chicken Bacon pizza with white sauce is still ove favorite after all these years and a good deal too! A large is about $10.80. Users/jsbmeb

20110223 00:48:06 nbsp Went to Pizza Guys late (after 9pm) today. Food was good but I felt extremely uncomfortable because a crowd of shadylooking loiterers started forming outside while I was eating inside. If you want pickup, go during the daytime. After nighttime, have it delivered. I had to call a cab. Users/rrenati

20110223 04:01:30 nbsp Bought some pizza for the first time in months from this place... Little Ceasars has better quality and that is saying something...  About the only edible thing on it was the crust.

meh.. what can one expect from a place whose drivers drive like bats out of hell and employees who throw soda bottles on the roof of the place they work at...  Yes, if you are the owner, take a look on your roof... not to mention the nighttime smoke sessions they have in the parking lot from time to time, and Im not talking about cigarettes. Users/WesP

20110316 22:42:15 nbsp Admittedly, Im not a big pizza connoisseur, but I immediately noticed the poor quality of the food that the Pizza Guys deliver.
I have never really understood when people complain about badtextures with pizza. I mean pizza is pizza, right? Its pretty hard to mess up.
But the pizza I got from this place had noticeably rubbery cheese, fairly tasteless crust , and weirdly undercooked pepperoni (if there is such a thing)it was as if it was put on the pizza AFTER it was  brought out of the oven.

In all, Im not going to spend my money there again.
My suggestion: If you want cheap, go cenarios cheese  YUM, flavorful, melty, and if you want the primo delivered pizza Id say get some the stuff from Steves place. Users/someday909

20110321 20:04:17 nbsp Did I already mention these guys are ALWAYS late. Well here I go again. I call in a order for pickup and they tell me it will be ready in 25 minutes. I arrive there 40 minutes later and the guy is like, 6 minutes, no 5 minutes. I walk out for a minute and walk back in to find him making my calzone and putting it in the oven. I ask is that my order, did you forget about it? He responds that he was busy taking and making orders. Dude, dont say 25 minutes if youre not going to start the thing until I arrive 40 minutes later. Users/djnurco

20110517 17:34:12 nbsp Put in a delivery order over an hour ago  it still hasnt arrived. The pizzas good, but I suppose ordering for takeout would be best. Users/MarkTwain

20110809 16:41:35 nbsp Pizza and drugs is a good combination. You can purchase drugs from the unattractive, red headed fellow at Pizza Guys while hes working. One thing thats not cool, Ive seen him sell weed to a pretty young looking kid.  Users/friendthegirl

20110824 20:03:33 nbsp pizza guys is not stingy on toppings fool
 Users/bambamred

20110824 20:08:18 nbsp theplace takes so long to get shit cuz ther are under staffed u get it stop bitchen bout it takin so long and tlk to the owners cuz the people ther for the most part work hard Users/bambamred

20110824 22:07:46 nbsp I called to order a medium pizza one day for myself and one other person.  The employee confirmed my order and then quickly said an extra large would be cheaper, and hung up.  He took my order from a medium to an extra large without consulting me at all.  Even if it was more cost effective that was bizarre and not what I wanted.  The pizza was just okay, nothing special.  I had an inordinate amount of leftovers and have not gone back. Users/LoriOrf

20111009 20:14:13 nbsp I used to like them, but they got two orders wrong IN A ROW. Something horrible happened to the customer service. So only go here if youre willing to A) wait forever or B) willing to have your order taken wrong.  Users/Inyx

20111119 22:55:41 nbsp Pizza Guys was kind enough to bring deeply discounted pizzas to the peaceful protest of Katehis press conference today. :) Users/zombiek

20111208 18:03:04 nbsp its cheap and a ton of food and its great for when the guys are coming over but I wouldnt get it if it was just me solo† Users/KellenRuel

20120424 17:28:09 nbsp Pizza is not great, but it has the BEST cheesy garlic bread. For the price there is not a better Pizza in town, way better than Dominoes.  Users/JoeRandom

20120508 23:50:07 nbsp Hi,
I would like to leave my feedback about Pizza Guys Co and specifically the branch Im the always customer at. Ive been to a couple of different locations throughout Sacramento but my favourite is the one on L str in Davis, CA. Even though its a little far for me I go only there because of their delucious pizza that generously cooked by the family members. Those people because they are the family make this place special. They are so friendly, polite, pleasant to deal with, they always do everything to satisfy even the most picky customer. Service is great, atmosphere is friendly, place is very clean itself. Recently they bought new tables and chairs, I wish such places had TVs so we could come and watch soccer in this cosy pizzeria. But the most important is their pizzas and actually the whole menu, its cooked professionally. Lots of puzzeria try to cut expenses by underfilling pizzas with topings, Pizza in Davis is always overfilling thats really very nice of them cause I as a customer realise that people working there are trying to do a good business instead of cutting expenses by cooking unperfect meal. Users/Mv17429
  Is it wrong to be suspicious of this comment? If I am wrong, and this is a legit comment left by someone with no personal connextion the the business, then my bad. But this seems fishy to me.  Users/jsbmeb

20120509 21:54:38 nbsp yes it is!! Users/Theangrydiner

20120510 16:32:51 nbsp That comment may be suspicious, but I live nearby and also frequent the L Street shop and agree with every word.  Users/AJThompson

20130530 23:01:00 nbsp The customer service is awful. I was told 20 min before closing that they were no longer accepting new orders. Guess she had something more important to do then her job. She did however let me know they would be open tomorrow at 11. Great... Will not be eating here again Users/PhillipLiems
  Maybe they had a lot of orders and she had something more important to do than work well past closing time of 10pm on a work/school night.  They do need to bake and deliver the pie after all those other last minute orders.  Users/RyanMeyerhoff

20130531 00:42:15 nbsp Great pizza.  My pickup orders have always been on time. Users/RyanMeyerhoff

20131112 20:43:35 nbsp Best Pizza Place ever!
First of all it is clean. Second is the service. I love that it is operated by a family: husband, wife and 3 of their sons. They are always friendly to customers, very helpful and ready to do good deals. Every time I order something or stop by to pick up my order, I feel like they really appreciate their customers and take care of their business. Prices are pretty cheap plus there are always lots of deals.
Thank you Pizza Guys Davis for the best Pizza Place!!!!!!!!!!! Users/MichelleVee

20140724 21:23:36 nbsp Consistently great pizza. I have had better for sure, but this place is my go to place in Davis. You even get surprised with an exceptional pizza every now and then. Users/JakeDuCharme


text: #redirect Users/NxTx


text:
	SUBROUTINE IN_LINE ( line, values, nexp, icolor, itype, iwidth,
     +			     ilabel, smooth, filter, scflag, iret )
C************************************************************************
C* IN_LINE								*
C*									*
C* This subroutine converts the input for the LINE variable into a	*
C* list of colors, line types, line widths and line label flags.	*
C* If the number of specifications is less than the number expected,	*
C* the input sequence will be repeated to fill the buffer.		*
C* A smoothing level is also specified and applied to all lines.	*
C*									*
C* The LINE input must be of the form:					*
C*									*
C*      col1;col2;.../typ1;typ2.../wid1;wid2.../lab1;lab2.../smth/fltr	*
C*									*
C* In general, lines are turned off by specifying color equal to 0.	*
C* 0 for line type or width will use a default value of 1.  0 for	*
C* line label will suppress labelling.					*
C*									*
C* Note that the colors can now be set or queried by name.  See IN_COLR	*
C* for details.								*
C*									*
C* If the line type is set to a single negative number, negative	*
C* values will have the line type specified and positive values		*
C* will be solid (line type = 1).  If the label is set to a single	*
C* number, say n, then every nth value will be labelled.  If label is	*
C* set to a negative value, -n, then every nth value will be labelled, 	*
C* but the line will not break for the label.				*
C*									*
C* The smoothing is a single value which specifies the amount of	*
C* smoothing to perform on the lines.  0 means that no smoothing will	*
C* occur, and is the default.						*
C*									*
C* The filter is a real value from 0 to 1 that specifies a filter for	*
C* the number of points along a line.					*
C*									*
C* IN_LINE ( LINE, VALUES, NEXP, ICOLOR, ITYPE, IWIDTH, ILABEL,		*
C*	     SMOOTH, FILTER, SCFLAG, IRET )				*
C*									*
C* Input parameters:							*
C*	LINE		CHAR*		LINE input			*
C*	VALUES (NEXP)	REAL		Data values to draw and label	*
C*	NEXP		INTEGER		Number expected			*
C*									*
C* Output parameters:							*
C*	ICOLOR (NEXP)	INTEGER		Color number array		*
C*	ITYPE  (NEXP)	INTEGER		Line type number array		*
C*	IWIDTH (NEXP)	INTEGER		Line width number array		*
C*	ILABEL (NEXP)	INTEGER		Line label number array		*
C*	SMOOTH		REAL		Line smoothing density		*
C*	FILTER		REAL		Line point filter		*
C*	SCFLAG		LOGICAL		Suppress small contour flag	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* K. Brill/GSC		06/90						*
C* S. Schotz/GSC	 7/90	Added negative contour feature, also	*
C*				reordered line input			*
C* M. desJardins/GSFC	 9/90	Fix error when no labels are requested	*
C* S. Schotz/GSC	 9/90	Can now query or set color name, call	*
C*				IN_COLR for color parsing		*
C* J. Whistler/SSAI	 4/92	Increased the size of group array	*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C* S. Jacobs/NCEP	 1/99	Added smoothing level to call		*
C* S. Jacobs/NCEP	 1/99	Allow negative label frequency		*
C* T. Piper/GSC		 3/99	Corrected prolog			*
C* S. Jacobs/NCEP	 5/99	Added line point filter			*
C* T. Lee/SAIC		12/01	Increased group string length to LLMXLN	*
C* C. Bailey/HPC	10/06	Added suppress small contour flag	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	CHARACTER*(*)	line
	INTEGER		icolor (*), itype (*), iwidth (*), ilabel (*)
	REAL		values (*)
C*
	CHARACTER	group (7)* (LLMXLN)
	LOGICAL		scflag
	INTEGER		iscflag
C------------------------------------------------------------------------
	iret = 0
	scflag = .false.
C
C*	Break list into four groups.
C
	CALL ST_CLST  ( line, '/', ' ', 7, group, ng, ier )
	DO  i = 1, 4
	    IF  ( group(i) .eq. ' ' )  group(i) = '1'
	END DO
	IF  ( group(5) .eq. ' ' )  group(5) = '0'
	IF  ( group(6) .eq. ' ' )  group(6) = '0'
	IF  ( group(7) .eq. ' ' )  group(7) = 'F'
C
C*      Decode color, type, width and label parts
C
	CALL IN_COLR ( group (1), nexp, icolor, ier )
        CALL ST_ILST ( group (2), ';', 0, nexp, itype,  ntyp, ier)
        CALL ST_ILST ( group (3), ';', 0, nexp, iwidth, nwid, ier)
        CALL ST_ILST ( group (4), ';', 0, nexp, ilabel, nlab, ier)
	CALL ST_NUMB ( group (5), ismoth, ier )
	CALL ST_CRNM ( group (6), filter, ier )
C
	CALL ST_LCUC ( group (7), group (7), ier )
	iscflag = INDEX ( group(7)(1:1), 'T' )
	IF ( iscflag .ne. 0 ) THEN
	    scflag = .true.
	END IF
C
	IF  ( ismoth .eq. 2 )  THEN
	    smooth = 5.0
	  ELSE IF  ( ismoth .eq. 1 )  THEN
	    smooth = 1.0
	  ELSE
	    smooth = 0.0
	END IF
C
C*	Set defaults for no entry.
C
	IF  ( ntyp .eq. 0 )  THEN
	    ntyp       = 1
	    itype  (1) = 1
	END IF
	IF  ( nwid .eq. 0 )  THEN
	    nwid       = 1
	    iwidth (1) = 1
	END IF
	IF  ( nlab .eq. 0 )  THEN
	    nlab       = 1
	    ilabel (1) = 1
	END IF
C
C*	Set the repeated patterns to fill buffer.
C
	IF  ( nwid .lt. nexp )  THEN
	    DO  i = nwid + 1, nexp
		j = MOD ( i-1, nwid ) + 1
		iwidth (i) = iwidth ( j )
	    END DO
	END IF
C
C*      If linetype is a single negative number, set positive numbers
C*      to solid and negative values to line type specified.  Otherwise
C*      repeat pattern to fill buffer if necessary.
C
	IF  ( (ntyp .eq. 1) .and. (itype(1) .lt. 0) ) THEN
	    jtype = - itype (1)
C
C*	    Check for positive or negative numbers.
C
	    DO  i = 1, nexp
	        IF  ( values (i) .ge. 0 )  THEN
		    itype (i) = 1
		  ELSE
		    itype (i) = jtype
		END IF
	    END DO
          ELSE
	    IF  ( ntyp .lt. nexp )  THEN
	        DO  i = ntyp + 1, nexp
		    itype  (i) = itype  ( MOD ( i-1, ntyp ) + 1 )
	        END DO
	    END IF
        END IF
C
C*      If label is a single number n, then label every nth contour.
C*      Otherwise repeat buffer to fill buffer if necessary.
C
	IF  ( ( nlab .eq. 1 ) .and.
     +	      ( ABS ( ilabel (1) ) .gt. 1 ) ) THEN
	    j = ABS ( ilabel (1) )
	    k = SIGN ( 1, ilabel (1) )
	    DO  i = 1, nexp
		IF  ( MOD ( i, j ) .eq. 1 )  THEN
		    ilabel (i) = 1 * k
		  ELSE
		    ilabel (i) = 0
		END IF
	    END DO
	  ELSE IF  ( nlab .eq. 1 )  THEN
	    j = ilabel (1)
	    DO  i = 1, nexp
		ilabel (i) = j
	    END DO
	  ELSE
	    IF  ( nlab .lt. nexp )  THEN
	        DO  i = nlab + 1, nexp
		    j = MOD ( i-1, nlab ) + 1
		    ilabel (i) = ilabel ( j )
	        END DO
	    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