text:
Crane Flies look like giant mosquitoes, but are really just big (about one to two inches long), clumsy flies and do no harm  they neither bite, sting, nor feed... their only purpose is to mate and lay eggs, like many adult insects (and other organisms for that matter). Those most commonly found in Davis are the Turfgrass  or European Crane Fly (Tipula paludosa). Though crane fly larva can be an agricultural pest in areas of high moisture, larva are not much of a problem here, and the adults are little more than a bedroom nuisance in warm dry inland areas. Because they are attracted to light, like moths, we typically get to enjoy them in the evenings when they join us indoors. In addition, winter crane fly larva are considered forensically significant under certain circumstances.

Despite the common name of Mosquito Hawk and Skeeter Eater, these large flies unfortunately dont help to reduce the mosquito population. The name possibly comes from the resemblance to mosquito (which shares a taxonomic group with the crane fly, Nematocera) and their large size, compared to the mosquito.

Crane flies grow to about 2.5 inches long with a 3 inch wingspan. Grayishbrown and slender, its their long thin legs and the way they dance about that many people find most disturbing. Like daddy long leg spiders, their legs are about twice as long as their bodies. In their adult form, crane flies only live for a couple of days and do not usually feed. Adults emerge from the soil beneath grassy areas in late summer and fall, mate, and females lay eggs within 24 hours. Crane fly eggs hatch into small, brown larvae with tough skin; these leatherjackets feed on the roots and eat decaying town flora plants, dead leaves, fungi, and plant roots during the fall before overwintering in the soil. When the weather warms in spring, larvae resume feeding. During the day larvae mostly stay underground, but on damp, warm nights they come to the surface to feed on the aboveground parts of many plants. When mature, the larvae are a little over an inch long. Around midMay they enter a nonfeeding pupal stage and remain just below the soil surface. In late summer, pupae wriggle to the surface and a single generation of adults emerges each year. Reaching adulthood en masse, one can see swarms of males learn to dance dance above treetops looking for females with which to mate.

Crane flies have many predators. Larvae and pupae are dug up by skunks and moles while aquatic larvae are eaten by fish, turtles, and other underwater predators. Adult crane flies are eaten by birds and bird watching birds and bats. From an aquatic perspective, crane flies are indicators of decent water quality, i.e. water that isnt too polluted, but probably has some degree of turbidity and stagnation  for more on benthic macroinvertebrates, see http://kywater.org/ww/bugs/intro.htm kywater.org.

Visit the http://www.ipm.ucdavis.edu/PMG/r785301411.html UC Integrated Pest Management site for additional information on crane flies and control mechanisms. Visit our Town Wildlife page to learn about other bugs and such inhabiting Davis.

20110413 12:49:46 nbsp Thank you for the informative page! Users/DanielleC

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      program grid_360
      use mod_za  ! HYCOM array I/O interface
      implicit none
c
      integer   ic,i,j,l
      real      hmaxa,hmaxb,hmina,hminb
      character cline*80
c
      integer, allocatable :: ip(:,:)
      real,    allocatable ::  p(:,:)
c
c --- create a regional.grid file with latitudes between 0 and 360.
c
      call xcspmd  !input idm,jdm
      allocate( ip( idm,jdm) )
      allocate(  p( idm,jdm) )
c
c --- read  in  regional.grid
c --- write out regional.grid.360
c
      call zaiost
c
      call zhopnc(21, 'regional.grid.b',      'formatted', 'old', 0)
      call zaiopf('regional.grid.a',      'old', 21)
c
      call zhopnc(61, 'regional.grid.360.b',  'formatted', 'new', 0)
      call zaiopf('regional.grid.360.a',  'new', 61)
c
      do l= 1,3
        read( 21,'(a)')      cline
        write(61,'(a)') trim(cline)
      enddo
c
      do l= 1,4 !lon,lat pairs
        read(21,'(a)')      cline
        write(6,'(a)') trim(cline)
        ic = index(cline,'=')
        read (cline(ic+1:),*)   hminb,hmaxb
        call zaiord(p,ip,.false., hmina,hmaxa, 21)
        if     (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
     &          abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4     ) then
          write(6,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
     &      'error - .a and .b grid files not consistent',
     &      '.a,.b min = ',hmina,hminb,hmina-hminb,
     &      '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
          call zhflsh(6)
          stop
        endif
        call lon360(p,idm,jdm)
        call zaiowr(p, ip,.false., hmina,hmaxa, 61, .false.)
        write(61,'(a,2f15.5)') cline(1:ic+1),hmina,hmaxa
        write(6, '(a,2f15.5)') cline(1:ic+1),hmina,hmaxa
c
        read( 21,'(a)')      cline
        write(6, '(a)') trim(cline)
        write(61,'(a)') trim(cline)
        call zaiord(p, ip,.false., hmina,hmaxa, 21)
        call zaiowr(p, ip,.false., hmina,hmaxa, 61, .false.)
      enddo
c
      do l= 1,11  !rest of the fields
        read( 21,'(a)')      cline
        write(6, '(a)') trim(cline)
        write(61,'(a)') trim(cline)
        call zaiord(p, ip,.false., hmina,hmaxa, 21)
        call zaiowr(p, ip,.false., hmina,hmaxa, 61, .false.)
      enddo
c
      close( unit=61)
      call zaiocl(61)
c
      end
      subroutine lon360(plon,idm,jdm)
      implicit none
c
      integer idm,jdm
      real    plon(idm,jdm)
c
c     move longitude to the range 0 to 360
c
      integer i,j
c
      do j= 1,jdm
        do i= 1,idm
          if     (plon(i,j).lt.-720.0) then
            plon(i,j) = mod(plon(i,j)+1080.0,360.0)
          elseif (plon(i,j).lt.-360.0) then
            plon(i,j) = mod(plon(i,j)+ 720.0,360.0)
          elseif (plon(i,j).lt.  0.0) then
            plon(i,j) = mod(plon(i,j)+ 360.0,360.0)
          elseif (plon(i,j).gt.360.0) then
            plon(i,j) = mod(plon(i,j),360.0)
          endif
        enddo
      enddo
      return
      end

ext: f

max_stars_repo_name: TillRasmussen/HYCOM-tools

max_issues_repo_name: TillRasmussen/HYCOM-tools

max_forks_repo_name: TillRasmussen/HYCOM-tools


text:
    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    ThermoOutput.f90
    !> \brief   This subroutine determines which values are to be provided as output.
    !> \author  M.H.A. Piro
    !> \date    May 8, 2012
    !> \sa      Thermochimica.f90
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   05/08/2012      M.H.A. Piro         Original code
    !
    !
    ! Purpose
    ! =======
    !
    !> \details The purpose of this subroutine is to store particular information that is requested as output.
    !! This is done to avoid unnecessary use of memory.  Note that it is possible that information is requested
    !! that is not in the system.  This subroutine first checks to see if the requested information is even
    !! in the system and then it checks to see if the particular species or phase is stable at equilibrium.
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    ! GetSolnPhaseIndex     An integer scalar representing the absolute index of a solution phase.
    ! dSolnPhaseMolesOut    A double real vector representing the number of moles of particular solution phases
    !                        requested as output.  If this phase is not present at equilibrium, it is assigned
    !                        a value of zero.
    ! dPureConPhaseMolesOut A double real vector representing the number of moles of particular pure condensed
    !                        phases requested as output.  If this phase is not present at equilibrium, it is
    !                        assigned a value of zero.
    ! dSpeciesMoleFractionOut A double real vector representing the mole fraction of particular soluton species
    !                        requested as output.  If this species is not present at equilibrium, it is
    !                        assigned a value of zero.
    ! IsSolnPhaseInSys      A character string indicating whether a particular solution phase is in the system
    !                        ('yes') or not ('no').
    ! IsPureConPhaseInSys   A character string indicating whether a particular pure condensed phase is in the
    !                        system ('yes') or not ('no').
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine ThermoOutput

    USE ModuleThermo
    USE ModuleThermoIO
    USE ModuleGEMSolver

    implicit none

    integer::   i, j, k, GetSolnPhaseIndex, clength
    logical::   IsSolnPhaseInSys, IsPureConPhaseInSys

    ! Initialize variables:
    dSolnPhaseMolesOut      = 0D0
    dPureConPhaseMolesOut   = 0D0
    dSpeciesMoleFractionOut = 0D0

    ! Only proceed if there haven't been any previously encountered errors:
    if (INFOThermo == 0) then

        ! ----------------
        ! SOLUTION PHASES:
        ! ----------------

        LOOP_SolnPhasesOut: do i = 1, nSolnPhasesOut

            ! Check if this solution phase is in the system:
            if (IsSolnPhaseInSys(cSolnPhaseNameOut(i)) ) then
                ! The solution phase requested is in the system. Check if it is stable at equilibrium:
                LOOP_nSolnPhases: do j = 1, nSolnPhases
                    k = -iAssemblage(nElements - j + 1)         ! Absolute solution phase index in system.
                    if (cSolnPhaseNameOut(i) == cSolnPhaseName(k)) then
                        ! This solution phase is expected to be stable at equilibrium.
                        ! Store the number of moles of this phase:
                        dSolnPhaseMolesOut(i) = dMolesPhase(nElements - j + 1)
                        exit LOOP_nSolnPhases
                    end if
                end do LOOP_nSolnPhases
            else
                ! The solution phase requested as output is not in the system.  Placeholder if an error should be
                ! reported at a later time.
            end if
        end do LOOP_SolnPhasesOut

        ! -----------------
        ! SOLUTION SPECIES:
        ! -----------------

        LOOP_SpeciesOut: do i = 1, nSpeciesOut
            ! First, make sure that the solution phase that this species belongs to is in the system:
            if (IsSolnPhaseInSys(cSpeciesPhaseOut(i)) ) then
                ! Get the solution phase index:
                k = GetSolnPhaseIndex(cSpeciesPhaseOut(i))

                if (k == 0) cycle LOOP_SpeciesOut

                clength=LEN(cSpeciesNameOut(i))
                clength=clength-1
                cSpeciesNameOut(i) = ' ' // cSpeciesNameOut(i)(1:clength)

                ! Loop through all species in this solution phase:
                LOOP_SpeciesInSoln: do j = nSpeciesPhase(k-1) + 1, nSpeciesPhase(k)
                    if (cSpeciesNameOut(i) == cSpeciesName(j)) then
                        dSpeciesMoleFractionOut(i) = dMolFraction(j)
                        exit LOOP_SpeciesInSoln
                    end if
                end do LOOP_SpeciesInSoln
            else
                ! The solution phase that this species belongs to is not part of the system.
                ! This is a placeholder for later.
            end if
        end do LOOP_SpeciesOut

        ! ----------------------
        ! PURE CONDENSED PHASES:
        ! ----------------------

        LOOP_PureConPhasesOut: do i = 1, nPureConPhaseOut

            ! Check if this pure condensed phase is in the system:
            if (IsPureConPhaseInSys(cPureConPhaseNameOut(i))) then
                ! The pure condensed phase requested as output is in the system.
                ! Check if it is stable at equilibrium:
                LOOP_nConPhases: do j = 1, nConPhases
                    k = iAssemblage(j)      ! Absolute pure condensed phase index in system.
                    if (cPureConPhaseNameOut(i) == cSpeciesName(k)) then
                        ! This pure condensed phase is expected to be stable at equilibrium.
                        ! Store the number of moles of this phase:
                        dPureConPhaseMolesOut(i) = dMolesPhase(j)
                        exit LOOP_nConPhases
                    end if
                end do LOOP_nConPhases
            else
                ! The pure condensed phase requested as output is not in the system.  Placeholder if an error
                ! should be reported at a later time.
            end if
        end do LOOP_PureConPhasesOut

    else
        ! Provide null values if an error has been detected.
    end if

    return

end subroutine ThermoOutput

    !-------------------------------------------------------------------------------------------------------------
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   05/08/2012      M.H.A. Piro         Original code
    !
    !
    ! Purpose
    ! =======
    !
    ! The purpose of this function is to determine whether a particular solution phase is in the system.  Note
    ! that this is not to be confused with a solution phase that is expected to be stable at equilibrium.
    !
    !-------------------------------------------------------------------------------------------------------------

function IsSolnPhaseInSys(cSolnPhaseNameOut)

    USE ModuleThermo

    implicit none

    integer::                 i
    character(*),intent(in):: cSolnPhaseNameOut
    logical::                 IsSolnPhaseInSys

    ! Initialize variables:
    IsSolnPhaseInSys = .FALSE.

    ! Check to see if this phase is even in the system:
    do i = 1, nSolnPhasesSys
        if (cSolnPhaseName(i) == cSolnPhaseNameOut) then
            IsSolnPhaseInSys = .TRUE.
            exit
        end if
    end do

end function IsSolnPhaseInSys

    !-------------------------------------------------------------------------------------------------------------
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   05/08/2012      M.H.A. Piro         Original code
    !
    !
    ! Purpose
    ! =======
    !
    ! The purpose of this function is to get the index of a requested solution phase.
    !
    !-------------------------------------------------------------------------------------------------------------

function GetSolnPhaseIndex(cSolnPhaseNameOut)

    USE ModuleThermo

    implicit none

    integer::                 i, GetSolnPhaseIndex
    character(*),intent(in):: cSolnPhaseNameOut

    ! Initialize variables:
    GetSolnPhaseIndex = 0

    ! Check to see if this phase is even in the system:
    do i = 1, nSolnPhasesSys
        if (cSolnPhaseName(i) == cSolnPhaseNameOut) then
            GetSolnPhaseIndex = i
            exit
        end if
    end do

end function GetSolnPhaseIndex

    !-------------------------------------------------------------------------------------------------------------
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   05/08/2012      M.H.A. Piro         Original code
    !
    !
    ! Purpose
    ! =======
    !
    ! The purpose of this function is to determine whether a particular pure condensed phase is in the system.
    ! Note that this is not to be confused with a pure condensed phase that is expected to be stable at
    ! equilibrium.
    !
    !-------------------------------------------------------------------------------------------------------------

function IsPureConPhaseInSys(cPureConPhaseNameOut)

    USE ModuleThermo

    implicit none

    integer::                 i
    character(*),intent(in):: cPureConPhaseNameOut
    character(26)::           cTemp
    logical::                 IsPureConPhaseInSys

    ! Initialize variables:
    IsPureConPhaseInSys = .FALSE.

    cTemp = ' ' // cPureConPhaseNameOut

    ! Check to see if this phase is even in the system:
    do i = nSpeciesPhase(nSolnPhasesSys) + 1, nSpecies

        if (cSpeciesName(i) == cTemp) then
            IsPureConPhaseInSys = .TRUE.
            exit
        end if
    end do

end function IsPureConPhaseInSys

max_issues_repo_name: nikolasscuro/thermochimica

max_forks_repo_name: nikolasscuro/thermochimica


text:
      program prog
      write(6, *) 'some here                                            x

                                                                        x

     & and more'
      end


text:
      INTEGER FUNCTION ipmpar(i)
C-----------------------------------------------------------------------
C  INTEGERS.
C
C     ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM
C
C               SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) )
C
C               WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1.
C
C     IPMPAR(1) = A, THE BASE.
C     IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS.
C     IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE.
C
C  FLOATING-POINT NUMBERS.
C
C     IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING
C     POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE
C     NONZERO NUMBERS ARE REPRESENTED IN THE FORM
C
C               SIGN (B**E) * (X(1)/B + ... + X(M)/B**M)
C
C               WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M,
C               X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX.
C
C     IPMPAR(4) = B, THE BASE.
C  SINGLE-PRECISION
C     IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS.
C     IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E.
C     IPMPAR(7) = EMAX, THE LARGEST EXPONENT E.
C  DOUBLE-PRECISION
C     IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS.
C     IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E.
C     IPMPAR(10) = EMAX, THE LARGEST EXPONENT E.
C-----------------------------------------------------------------------
C     RWRITTEN BY JPC to use lapack dlamch + a small c program
C     for ipmpar(3)
C-----------------------------------------------------------------------
      DOUBLE PRECISION   DLAMCH
      EXTERNAL DLAMCH
C      include 'stack.h'
      goto (1,1,3,4,1,1,1,1,9,10) i
 1    continue
      call basout(io,wte,'ipmpar called with wrong argument')
      ipmpar = 0
      return
 3    ipmpar = largestint()
      return
 4    ipmpar=dlamch('b')
      return
 9    ipmpar=dlamch('m')
      return
 10   ipmpar= dlamch('l')
      END

max_stars_repo_name: alpgodev/numx

max_issues_repo_name: alpgodev/numx

max_forks_repo_name: alpgodev/numx


text:
      subroutine HALVEINT(
     &           arr
     &           ,iarrlo0
     &           ,iarrhi0
     &           ,narrcomp
     &           ,ibxlo0
     &           ,ibxhi0
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer narrcomp
      integer iarrlo0
      integer iarrhi0
      integer arr(
     &           iarrlo0:iarrhi0,
     &           0:narrcomp-1)
      integer ibxlo0
      integer ibxhi0
      integer i0
      integer var
      do var = 0, narrcomp-1
      do i0 = ibxlo0,ibxhi0
            arr(i0, var) = arr(i0, var) / 2
      enddo
      enddo
      return
      end


text:
c======================================================================
c
c !IROUTINE: WETBULBCALC -- Calculate wet bulb temperature (C)
c
c !DESCRIPTION:
c
c   Calculates wet bulb temperature in C, given pressure in
c      temperature in K and mixing ratio in kg/kg.
c
c !INPUT:
c    nx     - index for x dimension
c    ny     - index for y dimension
c    nz     - index for z dimension
c    prs    - pressure (mb)
c    tmk    - temperature (K)
c    qvp    - water vapor mixing ratio (kg/kg)
c
c !OUTPUT:
c    twb    - Wet bulb temperature (C)
c
c !ASSUMPTIONS:
c
c !REVISION HISTORY:
c     2009-March  - Mark T. Stoelinga - from RIP4.5
c     2010-August - J. Schramm
c     2014-March - A. Jaye - modified to run with NCL and ARW wrf output
c
c !INTERFACE:
c ------------------------------------------------------------------
C NCLFORTSTART
      subroutine wetbulbcalc(prs,tmk,qvp,twb,nx,ny,nz,psafile)
      implicit none
      integer nx, ny, nz
      double precision prs(nz,ny,nx)
      double precision tmk(nz,ny,nx)
      double precision qvp(nz,ny,nx)
      double precision twb(nz,ny,nx)
      character*(*) psafile
C NCLEND
      integer i,j,k
      integer jtch,jt,ipch,ip
      double precision q, t, p, e, tlcl, eth
      double precision fracip,fracip2,fracjt,fracjt2
      double precision PSADITHTE(150),PSADIPRS(150),PSADITMK(150,150)
      double precision tonpsadiabat
      double precision eps,tlclc1,tlclc2,tlclc3,tlclc4,gamma
      double precision gammamd,thtecon1,thtecon2,thtecon3,celkel
      double precision rgas,rgasmd,cp,cpmd

c
c  Before looping, set lookup table for getting temperature on
c  a pseudoadiabat.
c
      CALL DLOOKUP_TABLE(PSADITHTE,PSADIPRS,PSADITMK,psafile)

c  Define constants

      rgas=287.04  !J/K/kg
      rgasmd=.608   ! rgas_moist=rgas*(1.+rgasmd*qvp)
      cp=1004.     ! J/K/kg  Note: not using Bolton's value of 1005.7
      cpmd=.887   ! cp_moist=cp*(1.+cpmd*qvp)
      eps=0.622
      tlclc1=2840.
      tlclc2=3.5
      tlclc3=4.805
      tlclc4=55.
      gamma=rgas/cp
      gammamd=rgasmd-cpmd  ! gamma_moist=gamma*(1.+gammamd*qvp)
      thtecon1=3376. ! K
      thtecon2=2.54
      thtecon3=.81
      celkel=273.15

      DO k=1,nx
        DO j=1,ny
          DO i=1,nz
            q=dmax1(qvp(i,j,k),1.d-15)
            t=tmk(i,j,k)
            p=prs(i,j,k)/100.
            e=q*p/(eps+q)
            tlcl=tlclc1/(dlog(t**tlclc2/e)-tlclc3)+tlclc4
            eth=t*(1000./p)**(gamma*(1.+gammamd*q))*
     &         exp((thtecon1/tlcl-thtecon2)*q*(1.+thtecon3*q))

c
c   Now we need to find the temperature (in K) on a moist adiabat
c   (specified by eth in K) given pressure in hPa.  It uses a
c   lookup table, with data that was generated by the Bolton (1980)
c   formula for theta_e.
c
c     First check if pressure is less than min pressure in lookup table.
c     If it is, assume parcel is so dry that the given theta-e value can
c     be interpretted as theta, and get temperature from the simple dry
c     theta formula.
c

            if (p.le.psadiprs(150)) then
              tonpsadiabat=eth*(p/1000.)**gamma
            else
c
c   Otherwise, look for the given thte/prs point in the lookup table.
c
            do jtch=1,150-1
              if (eth.ge.psadithte(jtch).and.eth.lt.
     &              psadithte(jtch+1)) then
                 jt=jtch
                 goto 213
              endif
            enddo
            jt=-1
 213        continue
            do ipch=1,150-1
              if (p.le.psadiprs(ipch).and.p.gt.psadiprs(ipch+1)) then
                 ip=ipch
                 goto 215
              endif
            enddo
            ip=-1
 215        continue
            if (jt.eq.-1.or.ip.eq.-1) then
               print*,
     &           'Outside of lookup table bounds. prs,thte=',p,eth
              stop
            endif
            fracjt=(eth-psadithte(jt))/(psadithte(jt+1)-psadithte(jt))
            fracjt2=1.-fracjt
            fracip=(psadiprs(ip)-p)/(psadiprs(ip)-psadiprs(ip+1))
            fracip2=1.-fracip
            if (psaditmk(ip,jt).gt.1e9.or.psaditmk(ip+1,jt).gt.1e9.or.
     &          psaditmk(ip,jt+1).gt.1e9.or.
     &          psaditmk(ip+1,jt+1).gt.1e9) then
                print*,
     &            'Tried to access missing tmperature in lookup table.'
                print*,
     &            'Prs and Thte probably unreasonable. prs,thte='
     &                   ,p,eth
               stop
            endif
            tonpsadiabat=fracip2*fracjt2*psaditmk(ip  ,jt  )+
     &             fracip *fracjt2*psaditmk(ip+1,jt  )+
     &             fracip2*fracjt *psaditmk(ip  ,jt+1)+
     &             fracip *fracjt *psaditmk(ip+1,jt+1)
            endif

            twb(i,j,k)=tonpsadiabat

          ENDDO
        ENDDO
      ENDDO

c
      return
      end
c======================================================================
c
c !IROUTINE: omgcalc -- Calculate omega (dp/dt)
c
c !DESCRIPTION:
c
c   Calculate approximate omega, based on vertical velocity w (dz/dt).
c   It is approximate because it cannot take into account the vertical
c   motion of pressure surfaces.
c
c !INPUT:
c    mx - index for x dimension
c    my - index for y dimension
c    mx -  index for vertical dimension
c    qvp - water vapor mixing ratio (kg/kg)
c    tmk - temperature (K)
c    www - vertical velocity (m/s)
c    prs -  pressure (Pa)
c
c !OUTPUT:
c    omg - omega (Pa/sec)
c
c !ASSUMPTIONS:
c
c !REVISION HISTORY:
c     2009-March  - Mark T. Stoelinga - from RIP4.5
c     2010-August - J. Schramm
c     2014-March - A. Jaye - modified to run with NCL and ARW wrf output
c
c ------------------------------------------------------------------
c NCLFORTSTART
      subroutine omgcalc(qvp,tmk,www,prs,omg,mx,my,mz)
      implicit none
      integer mx, my, mz
      double precision qvp(mz,my,mx)
      double precision tmk(mz,my,mx)
      double precision www(mz,my,mx)
      double precision prs(mz,my,mx)
      double precision omg(mz,my,mx)
c NCLEND
c Local variables
      integer i, j, k
      double precision grav,rgas,eps
c
c Constants
c
      grav=9.81           ! m/s**2
      rgas=287.04  !J/K/kg
      eps=0.622

      do k=1,mx
        do j=1,my
          do i=1,mz
            omg(i,j,k)=-grav*prs(i,j,k)/
     &        (rgas*((tmk(i,j,k)*(eps+qvp(i,j,k)))/
     &        (eps*(1.+qvp(i,j,k)))))*www(i,j,k)
          enddo
        enddo
      enddo
c
      return
      end
c======================================================================
c
c !IROUTINE: VIRTUAL_TEMP -- Calculate virtual temperature (K)
c
c !DESCRIPTION:
c
c   Calculates virtual temperature in K, given temperature
c      in K and mixing ratio in kg/kg.
c
c !INPUT:
c    NX     - index for x dimension
c    NY     - index for y dimension
c    NZ     - index for z dimension
c    RATMIX - water vapor mixing ratio (kg/kg)
c    TEMP   - temperature (K)
c
c !OUTPUT:
c    TV     - Virtual temperature (K)
c
c !ASSUMPTIONS:
c
c !REVISION HISTORY:
c     2009-March  - Mark T. Stoelinga - from RIP4.5
c     2010-August - J. Schramm
c     2014-March - A. Jaye - modified to run with NCL and ARW wrf output
c
c ------------------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE VIRTUAL_TEMP(TEMP,RATMIX,TV,NX,NY,NZ)
      IMPLICIT NONE
      INTEGER NX,NY,NZ
      DOUBLE PRECISION TEMP(NZ,NY,NX)
      DOUBLE PRECISION RATMIX(NZ,NY,NX)
      DOUBLE PRECISION TV(NZ,NY,NX)
C NCLEND
      INTEGER I,J,K
      DOUBLE PRECISION EPS
      EPS = 0.622D0
      DO K=1,NX
        DO J=1,NY
          DO I=1,NZ
            TV(I,J,K) = TEMP(I,J,K)* (EPS+RATMIX(I,J,K))/
     &                     (EPS* (1.D0+RATMIX(I,J,K)))
          ENDDO
        ENDDO
      ENDDO
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text: +bits=16 +latency=50

max_stars_repo_name: PeterMonsson/lpcm-verilator

max_issues_repo_name: PeterMonsson/lpcm-verilator

max_forks_repo_name: PeterMonsson/lpcm-verilator


text:
MODULE cable_sli_roots

  USE cable_dimensions, ONLY: r_2, i_d
  USE cable_sli_numbers,       ONLY: zero, half, one, two, e3

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: setroots, getrex ! routines

  ! b1, b2 - params used to get root distribution param b (Li et al., J Hydrolo 2001).
  REAL(r_2), PARAMETER :: b1     = 24.66
  REAL(r_2), PARAMETER :: b2     = 1.59
  REAL(r_2), PARAMETER :: lambda = 1.0

  INTERFACE setroots
     MODULE PROCEDURE setroots_1d
     MODULE PROCEDURE setroots_2d
  END INTERFACE setroots

  INTERFACE getrex
     MODULE PROCEDURE getrex_1d
     MODULE PROCEDURE getrex_2d
  END INTERFACE getrex

  ! Definitions:
  ! setroots - subroutine to set current root distribution based on Li, K.Y., De Jong, R. and J.B. Boisvert (2001).
  !            An exponential root-water-uptake model with water stress compensation. J. Hydrol. 252:189-204.
  ! getrex   - subroutine to get rate of water extraction from layers.

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

CONTAINS

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

  SUBROUTINE setroots_1d(x, F10, Zr, Fs)

    IMPLICIT NONE

    REAL(r_2), DIMENSION(:), INTENT(IN)  :: x
    REAL(r_2),               INTENT(IN)  :: F10
    REAL(r_2),               INTENT(IN)  :: Zr
    REAL(r_2), DIMENSION(:), INTENT(OUT) :: Fs
    ! Sets current weighted root length density distribn (Fs).
    !      Li et al. (J Hydrolo, 2001)
    ! Definitions of arguments:
    ! x(:) - depths to bottom of layers (cm).
    ! F10  - fraction of root length density in top 10% of the root zone
    ! Zr   - rooting depth (cm).
    INTEGER(i_d)                    :: ms
    REAL(r_2)                       :: b, extr
    REAL(r_2), DIMENSION(1:size(x)) :: ext0, ext1, xend, Fi
    REAL(r_2)                       :: tmp

    ms = size(x) ! soil layers

    xend(1)    = zero
    xend(2:ms) = x(1:ms-1)
    b          = b1 * F10**b2 / Zr ! root distrib param
    extr       = exp(-b*Zr)
    ext1(:)    = exp(-b*x(:))
    ext0(1)    = one
    ext0(2:ms) = ext1(1:ms-1)
    ! get fraction of root length density in layer i
    Fi(:) = (log((one+ext0(:))/(one+ext1(:))) + half*(ext0(:)-ext1(:))) / &
         (log(two/(one+extr)) + half*(one-extr))
    Fs(:) = exp(lambda*log(Fi(:))) ! weighted Fi
    where (xend(:) >= Zr) Fs(:) = zero

    ! ensure Fs sums to one
    tmp = sum(Fs(:))
    if (tmp > zero) then
       Fs(:) = Fs(:)/tmp
    else
       Fs(:) = zero
    endif

  END SUBROUTINE setroots_1d

  SUBROUTINE setroots_2d(x, F10, Zr, Fs)

    IMPLICIT NONE

    REAL(r_2), DIMENSION(:,:), INTENT(IN)  :: x
    REAL(r_2), DIMENSION(:),   INTENT(IN)  :: F10
    REAL(r_2), DIMENSION(:),   INTENT(IN)  :: Zr
    REAL(r_2), DIMENSION(:,:), INTENT(OUT) :: Fs
    ! Sets current weighted root length density distribn (Fs).
    !      Li et al. (J Hydrolo, 2001)
    ! Definitions of arguments:
    ! x(:) - depths to bottom of layers (cm).
    ! F10  - fraction of root length density in top 10% of the root zone
    ! Zr   - rooting depth (cm).
    INTEGER(i_d)                                  :: mp, ms
    REAL(r_2), DIMENSION(1:size(x,1))             :: b, extr
    REAL(r_2), DIMENSION(1:size(x,1),1:size(x,2)) :: ext0, ext1, xend, Fi
    REAL(r_2), DIMENSION(1:size(x,1),1:size(x,2)) :: tmp2d

    mp = size(x,1) ! landpoints
    ms = size(x,2) ! soil layers

    xend(1:mp,1)    = zero
    xend(1:mp,2:ms) = x(1:mp,1:ms-1)
    b(1:mp)         = b1 * F10(1:mp)**b2 / Zr(1:mp) ! root distrib param
    extr(1:mp)      = exp(-b(1:mp)*Zr(1:mp))
    tmp2d(:,:)      = spread(b(1:mp),2,ms)
    ext1(:,:)       = exp(-tmp2d(:,:)*x(:,:))
    ext0(1:mp,1)    = one
    ext0(1:mp,2:ms) = ext1(1:mp,1:ms-1)
    ! get fraction of root length density in layer i
    tmp2d(:,:)      = spread(extr(1:mp),2,ms)
    Fi(:,:)         = (log((one+ext0(:,:))/(one+ext1(:,:))) + half*(ext0(:,:)-ext1(:,:))) / &
         (log(two/(one+tmp2d(:,:))) + half*(one-tmp2d(:,:)))
    Fs(:,:)         = exp(lambda*log(Fi(:,:))) ! weighted Fi
    tmp2d(:,:)      = spread(Zr(1:mp),2,ms)
    where (xend(:,:) >= tmp2d(:,:)) Fs(:,:) = zero

    ! ensure Fs sums to one
    tmp2d(:,:) = spread(sum(Fs(1:mp,1:ms),2),2,ms)
    where (tmp2d(:,:) > zero)
       Fs(:,:) = Fs(:,:)/tmp2d(:,:)
    elsewhere
       Fs(:,:) = zero
    endwhere

  END SUBROUTINE setroots_2d

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

  SUBROUTINE getrex_1d(S, rex, fws, Fs, thetaS, thetaw, Etrans, gamma)

    ! Lai and Katul formulation for root efficiency function vh 17/07/09
    ! changed to MCs maximum formulation

    IMPLICIT NONE

    REAL(r_2), DIMENSION(:), INTENT(IN)    :: S      ! relative saturation
    REAL(r_2), DIMENSION(:), INTENT(OUT)   :: rex    ! water extraction per layer
    REAL(r_2),               INTENT(INOUT) :: fws    ! stomatal limitation factor
    REAL(r_2), DIMENSION(:), INTENT(IN)    :: Fs     ! root length density
    REAL(r_2), DIMENSION(:), INTENT(IN)    :: thetaS ! saturation soil moisture
    REAL(r_2), DIMENSION(:), INTENT(IN)    :: thetaw ! soil moisture at wiliting point
    REAL(r_2),               INTENT(IN)    :: Etrans ! total transpiration
    REAL(r_2),               INTENT(IN)    :: gamma  ! skew of Li & Katul alpha2 function

    ! Gets rate of water extraction compatible with CABLE stomatal conductance model
    ! theta(:) - soil moisture(m3 m-3)
    ! rex(:)   - rate of water extraction by roots from layers (cm/h).
    INTEGER(i_d)                                  :: ms
    REAL(r_2), DIMENSION(1:size(S)) :: theta, lthetar, alpha_root, delta_root
    REAL(r_2)                       :: trex

    ms = size(S) ! soil layers

    theta(:)   = S(:)*thetaS(:)
    lthetar(:) = log(max(theta(:)-thetaw(:),e3)/thetaS(:))

    where ((theta(:)-thetaw(:)) > e3)
       alpha_root(:) = exp( gamma/max(theta(:)-thetaw(:), e3) * lthetar(:) )
    elsewhere
       alpha_root(:) = zero
    endwhere

    where (Fs(:) > zero)
        delta_root(:) = one
    elsewhere
        delta_root(:) = zero
    endwhere

    rex(:) = alpha_root(:)*Fs(:)

    trex = sum(rex(:))
    if (trex > zero) then
       rex(:) = rex(:)/trex
    else
       rex(:) = zero
    endif
    rex(:) = Etrans*rex(:)

    fws    = maxval(alpha_root(:)*delta_root(:))

  END SUBROUTINE getrex_1d

  SUBROUTINE getrex_2d(S, rex, fws, Fs, thetaS, thetaw, Etrans, gamma)

    ! Lai and Katul formulation for root efficiency function vh 17/07/09
    ! changed to MCs maximum formulation

    IMPLICIT NONE

    REAL(r_2), DIMENSION(:,:), INTENT(IN)    :: S      ! relative saturation
    REAL(r_2), DIMENSION(:,:), INTENT(OUT)   :: rex    ! water extraction per layer
    REAL(r_2), DIMENSION(:),   INTENT(INOUT) :: fws    ! stomatal limitation factor
    REAL(r_2), DIMENSION(:,:), INTENT(IN)    :: Fs     ! root length density
    REAL(r_2), DIMENSION(:,:), INTENT(IN)    :: thetaS ! saturation soil moisture
    REAL(r_2), DIMENSION(:,:), INTENT(IN)    :: thetaw ! soil moisture at wiliting point
    REAL(r_2), DIMENSION(:),   INTENT(IN)    :: Etrans ! total transpiration
    REAL(r_2), DIMENSION(:),   INTENT(IN)    :: gamma  ! skew of Li & Katul alpha2 function

    ! Gets rate of water extraction compatible with CABLE stomatal conductance model
    ! theta(:) - soil moisture(m3 m-3)
    ! rex(:)   - rate of water extraction by roots from layers (cm/h).
    INTEGER(i_d)                                  :: mp, ms
    REAL(r_2), DIMENSION(1:size(S,1),1:size(S,2)) :: theta, lthetar, alpha_root, delta_root
    REAL(r_2), DIMENSION(1:size(S,1))             :: trex
    REAL(r_2), DIMENSION(1:size(S,1),1:size(S,2)) :: tmp2d

    mp = size(S,1) ! landpoints
    ms = size(S,2) ! soil layers

    theta(:,:)   = S(:,:)*thetaS(:,:)
    lthetar(:,:) = log(max(theta(:,:)-thetaw(:,:),e3)/thetaS(:,:))

    tmp2d = spread(gamma(1:mp),2,ms)
    where ((theta(:,:)-thetaw(:,:)) > e3)
       alpha_root(:,:) = exp( tmp2d(:,:)/max(theta(:,:)-thetaw(:,:), e3) * lthetar(:,:) )
    elsewhere
       alpha_root(:,:) = zero
    endwhere

    where (Fs(:,:) > zero)
        delta_root(:,:) = one
    elsewhere
        delta_root(:,:) = zero
    endwhere

    rex(:,:) = alpha_root(:,:)*Fs(:,:)

    trex  = sum(rex(:,:),2)
    tmp2d = spread(trex(1:mp),2,ms)
    where (tmp2d(:,:) > zero)
       rex(:,:) = rex(:,:)/tmp2d(:,:)
    elsewhere
       rex(:,:) = zero
    endwhere
    tmp2d    = spread(Etrans(1:mp),2,ms)
    rex(:,:) = tmp2d(:,:)*rex(:,:)

    fws(:)   = maxval(alpha_root(:,:)*delta_root(:,:),dim=2)

  END SUBROUTINE getrex_2d

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

END MODULE cable_sli_roots

max_stars_repo_name: KathyNie/LISF

max_issues_repo_name: dmocko/LISF

max_forks_repo_name: dmocko/LISF


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

Welcome to the Wiki Howdy, Mr. or Ms. LoverFootnote(I now have an image of you as a black and white movie version of Don Juan, silk scarf flowing in the wind, waxed mustache over a big smile.), and welcome to the wiki!   You might want to check out the importance of using your RealName, just so we can get to know you (or not: its your choice, but people were pretty friendly here).  My names Evan, pleased to meet you!  Thanks for adding your review to the Burgers and Brew entry!  Users/JabberWokky Evan JabberWokky Edwards


text:
subroutine coeffs(mbh,mdot,r,alpha,rho,T,H,A,M) bind(C)
implicit none
double precision, intent(in), value :: mbh,mdot,r,alpha,rho,T,H
double precision, intent(out) :: A(3,1), M(3,3)
A(1, 1) = 902184.7d0*H**3*alpha*rho*sqrt(1/(mbh**2*r**3)) - 1.975034d+18 &
      *mbh*mdot*(-1.732051d0*sqrt(1.0/r) + 1.0d0)
A(2, 1) = 2.081514d+14*H**4*alpha*rho**2*(1/(mbh**2*r**3))**1.5d0*( &
      6.13d+22*T**(-3.5d0)*rho + 0.3379305d0) - 0.0002268204d0*T**4
A(3, 1) = -5.154318d+9*H**2*rho*(1/(mbh**2*r**3))**1.0d0 + 2.521972d-15* &
      T**4 + 1.650222d+8*T*rho
M(1, 1) = 902184.7d0*H**3*alpha*sqrt(1/(mbh**2*r**3))
M(2, 1) = 1.275968d+37*H**4*T**(-3.5d0)*alpha*rho**2*(1/(mbh**2*r**3))** &
      1.5d0 + 4.163028d+14*H**4*alpha*rho*(1/(mbh**2*r**3))**1.5d0*( &
      6.13d+22*T**(-3.5d0)*rho + 0.3379305d0)
M(3, 1) = -5.154318d+9*H**2*(1/(mbh**2*r**3))**1.0d0 + 1.650222d+8*T
M(1, 2) = 0
M(2, 2) = -4.465888d+37*H**4*T**(-4.5d0)*alpha*rho**3*(1/(mbh**2*r**3)) &
      **1.5d0 - 0.0009072817d0*T**3
M(3, 2) = 1.008789d-14*T**3 + 1.650222d+8*rho
M(1, 3) = 2706554.0d0*H**2*alpha*rho*sqrt(1/(mbh**2*r**3))
M(2, 3) = 8.326056d+14*H**3*alpha*rho**2*(1/(mbh**2*r**3))**1.5d0*( &
      6.13d+22*T**(-3.5d0)*rho + 0.3379305d0)
M(3, 3) = -1.030864d+10*H*rho*(1/(mbh**2*r**3))**1.0d0
end subroutine

max_stars_repo_name: gronki/pydiskvert

max_issues_repo_name: gronki/pydiskvert

max_forks_repo_name: gronki/pydiskvert


text:
Eric Hoeprich is a worldreknown clarinetist who went to Davis schools and graduated from Davis Senior High School Davis High School in 1972.  One of his early school music teachers during this time was Margaret Neu.  He received a degree in  philosophy from http://en.wikipedia.org/wiki/Harvard Harvard, and currently teaches at the http://en.wikipedia.org/wiki/Paris_Conservatoire Paris Conservatoire, the http://en.wikipedia.org/wiki/Royal_Academy_of_Art,_The_Hague Royal Academy at The Hague, and the http://music.indiana.edu/departments/academic/earlymusic/ Early Music Institute at Indiana University, in addition to doing public performances.  He specializes in early clarinet music, beginning from the time of http://en.wikipedia.org/wiki/Clarinet_Concerto_(Mozart) Mozart and has written an authoritative book on the instrument called, http://www.amazon.com/ClarinetYaleMusicalInstrumentSeries/dp/0300102828/ The Clarinet.

In Sept. 2012, Hoeprich was inducted into the Davis Senior High School Hall of Fame Davis High School Hall of Fame.

Source: Hudson, Jeff; 2012 Aug. 23, http://www.davisenterprise.com/localnews/schoolsnews/erichoeprichachievedinternationalrenownwiththeclarinet/ Eric Hoeprich achieved international renown with the clarinet, Davis Enterprise, pg. A1.  Retrieved 25 Jan. 2013.


text:
module STK

  real*8, allocatable  :: lnTime(:),                                  &
                          normSource(:,:),                            &
                          fissionRate(:,:),                           &
                          absorbRate(:),                              &
                          leakageRate(:),                             &
                          initAbsorbMatrix(:,:,:),  absMatrix(:),     &
                          initFissionMatrix(:,:,:), fisMatrix(:),     &
                          leakageMatrix(:,:),       leakMatrix(:),    &
                          left(:), center(:), right(:),               &
                          typeSourceD(:)
  real, allocatable    :: typeSource(:)
  integer, allocatable :: cntStep(:), linToLn(:), matrStep(:),        &
                          signStep(:), arrNZIndices(:)

  real*8               :: minTime, stopTime, maxTime, dt, linTime,    &
                          lnTimeStep, lnTimeSum, timeInIf,            &
                          fRate, aRate, lRate
  integer              :: steps, numMatr, step, cnt,                  &
                          prprint, numOfZones, zone, noneZero,        &
                          neutronGenerationCount, modStep

  real*8               :: time(4)
  integer              :: params(4)

  integer        :: chnl_inp = 30,                                    &
                    chnl_out = 31
  character(100) :: nameinp = 'kin',                                  &
                    nameout = 'kin.out'

  contains

  integer function countNonZeroVectorElem(vector)
    real*8, intent(in) :: vector(numOfZones)
    integer            :: nonZero

    nonZero = 0
    do i = 1, numOfZones
      if (vector(i) > 0.0d0) nonZero = nonZero + 1
    enddo
    countNonZeroVectorElem = nonZero

    return
  end

  function arrayOfNonZeroElemIndices(vector,nonZero) result(indices)
    real*8, intent(in)   :: vector(numOfZones)
    integer,intent(in)   :: nonZero
    integer, allocatable :: indices(:)
    integer              :: counter

    allocate(indices(nonZero))
    indices = 0
    counter = 0

    do i = 1, numOfZones
      if (vector(i) > 0.0d0) then
        counter = counter + 1
        indices(counter) = i
      endif
    enddo

    return
  end

  real*8 function skipZeroSum(rowMatrix,vector)
    real*8, intent(in) :: vector(numOfZones), rowMatrix(numOfZones)
    real*8             :: vec

    vec = 0.0d0
!$  !Sum only non zero vector`s indices
    do j = 1, noneZero
      vec = vec + rowMatrix(arrNZIndices(j))*vector(arrNZIndices(j))
    enddo
    skipZeroSum = vec
    return
  end

end

max_stars_repo_name: plngu/stk

max_issues_repo_name: plngu/stk

max_forks_repo_name: plngu/stk


text:
The Student Services Maintenance Fee (SSMF) was voted upon during the Spring 1993 Quarter.  This was out of severe budget cuts killed practically all funding for UCD Athletics Intercollegiate Athletics, and Cowell Student Health Center.  This issue had a sunset clause that would make it expire in several years under the assumption that either the funding would return in the future with an improved economy, or students would have to vote it in again.  However, just two years later, the students were asked to pass the Student Activities and Services Initiative Fee (SASI) which made the originally temporary SSMF permanent.
Benefits
Prior to this initiative, students generally had to buy tickets to athletic events (albeit at a heavily discounted price), but afterward essentially you were already buying season tickets every quarter, so admission was free.  The other plus side was that attendance at events boomed since the starving college student didnt have to worry about buying tickets.  Although this is about the time Aggie Pack began as well, so it was probably a combination of factors.

The health center had few changes, but since visiting with a doctor was already free for students, it kept it accessible.
Drawbacks
One of the primary student leaders who spoke out in opposition to the SSMF was Peter Nguyen, ASUCD Internal Affairs Commission Chair and future ASUCD President.  He repeatedly argued that the SSMF boiled down to selftaxation for basic campus services students were already paying for, but to no avail as the Student Activities and Services Initiative Fee (SASI) and Student Services Health Fee subsequently passed.

UC Davis was one of the first Universities to propose such a fee, and it was subsequently copied all over the country during the poor economy of the early 90s.
The Hidden Agenda
The SSMF was primarily the brainchild of three people:  Bob Franks (Associate Vice ChancellorStudent Affairs), Larry Swanson (Associate Director of Athletics), and Scott Brayton (Athletic Department Intern at the time).  Franks and Swanson provided counsel and behindthescenes support, while Brayton was the studentathlete public face of the campaign.  Whether knowingly or not, Brayton advanced the UC Davis administrations desire to pass on the costs of Intercollegiate Athletics to a student tax rather than paying for it out of the Student Affairs budget (which, by the way, is already support by student fees and taxpayers).

Not coincidentally, Scott Brayton was rewarded for the passage of the SSMF with a fulltime career position in the UC Davis Athletics Department and is currently Associate Athletics Director / Auction, Marketing and Promotions.http://www.ucdavisaggies.com/staffdir/ucdastaff.html

Also not coincidentally, Larry Swanson and Scott Brayton formed the Aggie Pack in 1992 ostensibly as a spirit squad to support UC Davis Athletics.  Members of the Aggie Pack just happened to be the frontline volunteers in the campaign to pass the SSMF the very next year, 1993.  In other words, a universitysupport group served as a political action committee and campaign group to pass a student fee increase favored by the UC Davis administration.

20090410 18:01:38 nbsp I dont see what the hidden agenda is. It looks like it was a savvy campaign, whats wrong with that? Users/jsogul

20090410 18:16:07 nbsp The hidden agenda is that administrator and others on the university payroll are not supposed to interfere with a student election.  It is an ethical and likley legal violation.  Student initiatives should be studentinitiated, not administrator initiated. Users/maxtran

20090410 23:04:15 nbsp Its also not a coincidence that AVC Franks was a member of Sword and Sandals, and the S&S members were gung ho about SSMF. Users/BrentLaabs


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR 50919: [OOP] Don't use vtable for NON_OVERRIDABLE TBP
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>

module m

type t
contains
  procedure, nopass, NON_OVERRIDABLE :: testsub
  procedure, nopass, NON_OVERRIDABLE :: testfun
end type t

contains

  subroutine testsub()
    print *, "t's test"
  end subroutine

  integer function testfun()
    testfun = 1
  end function

end module m

  use m
  class(t), allocatable :: x
  allocate(x)
  call x%testsub()
  print *,x%testfun()
end

! { dg-final { scan-tree-dump-times "_vptr->" 0 "original" } }


text:
        subroutine i3LU (Diag, r, nvar, code)
c
c----------------------------------------------------------------------
c
c This routine performs a LU factorization/solve of a set of matrices,
c used for block diagonal preconditioning in the iterative driver.

c input:
c  Diag (nshg,nflow,nflow)  : block diagonal (symmetric storage)
c  r    (nshg,nflow)    : residual
c  code                 : operation code
c                           .eq. 'LU_Fact ', Cholesky Factor
c                           .eq. 'forward ', forward reduction
c                           .eq. 'backward', backward substitution
c                           .eq. 'product ', product Diag.r
c
c output:
c  Diag (nshg,nvar,nvar)  : LU decomp. of block diagonal
c  r    (nshg,nvar)    : reduced residual
c
c
c Note: the formulation used here is taken from Golub's "Matrix
c       Computations" Book (1984), pages 82-85 algorithm P5.1-3.
c
c       L and U overwrite Diag
c
c       The diagonal terms (i,i) of U are stored in inverted form.
c
c
c----------------------------------------------------------------------
c
        include "common.h"
c
        dimension Diag(nshg,nvar,nvar),        r(nshg,nvar)
c
        character*8 code

c
c.... perform LU decomposition with the Diagonal terms inverted
c
        if (code .eq. 'LU_Fact ') then
c
        do i = 1, nvar
          if (i .gt. 1) then
            do j = i, nvar
              do k = 1, i-1
                Diag(:,i,j) = Diag(:,i,j)
     &                      - Diag(:,i,k) * Diag(:,k,j)
              enddo
            enddo
          endif
c
          Diag(:,i,i) = one / Diag(:,i,i)
c
          if (i .lt. nvar) then
            do j = i+1, nvar
              if (i .gt. 1) then
                do k = 1, i-1
                  Diag(:,j,i) = Diag(:,j,i)
     &                        - Diag(:,j,k) * Diag(:,k,i)
                enddo
              endif
              Diag(:,j,i) = Diag(:,i,i) * Diag(:,j,i)
            enddo
          endif
        enddo
c
c  INACCURATE NOW     !      flops = flops + 110*nshg
c
          return
        endif  ! end LU_fact
c
c.... perform forward reduction
c
        if (code .eq. 'forward ') then
c
        do i = 2, nvar
           do j = 1, i-1
              r(:,i) = r(:,i) - Diag(:,i,j) * r(:,j)
           enddo
        enddo
c
c.... flop count
c
c  INACCURATE      !      flops = flops + 25*nshg
c
          return
        endif ! end forward
c
c.... perform backward substitution
c
        if (code .eq. 'backward') then
c
        r(:,nvar) = Diag(:,nvar,nvar) * r(:,nvar)

        do i = nvar-1, 1, -1
           do j = i+1, nvar
              r(:,i) = r(:,i) - r(:,j) * Diag(:,i,j)
           enddo
           r(:,i) = Diag(:,i,i) * r(:,i)
        enddo
c
c.... flop count
c
!      flops = flops + 25*nshg

          return
        endif ! end backward
c
c.... perform product U.r
c
        if (code .eq. 'product ') then
c
        do i = 1, nvar
           r(:,i) = r(:,i) / Diag(:,i,i)
           if (i .lt. nvar) then
              do j = i+1, nvar
                 r(:,i) = r(:,i) + r(:,j) * Diag(:,i,j)
              enddo
           endif
        enddo
c
c.... flop count
c
!      flops = flops + 40*nshg

          return
        endif ! end product
c
        call error ('i3LU    ', code, 0)
c
c.... return
c
c
111     format(5(e14.7,2x))
        return
        end


text:
        SUBROUTINE DG_NFIL  ( gdfile, gdoutf, iret )
C************************************************************************
C* DG_NFIL                                                              *
C*                                                                      *
C* This subroutine opens grid files and initializes the grid            *
C* diagnostics package.							*
C*                                                                      *
C* DG_NFIL  ( GDFILE, GDOUTF, IRET )					*
C*                                                                      *
C* Input parameters:                                                    *
C*      GDFILE          CHAR*           Grid file name or template      *
C*      GDOUTF          CHAR*           Output grid file name           *
C*                                                                      *
C* Output parameters:                                                   *
C*      IRET            INTEGER         Return code                     *
C*                                        0 = normal return             *
C*                                      -30 = error opening file        *
C*                                      -33 = too many files to open    *
C*                                      -51 = path associated with      *
C*                                            template does not exist	*
C*                                      -62 = grid file open failed     *
C**                                                                     *
C* Log:                                                                 *
C* R. Tian/SAIC		 3/06	Fortran wrapper of DGC_NFIL		*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
        CHARACTER*(*)   gdfile, gdoutf
C*
	CHARACTER	tmpgdi*(LLMXLN), tmpgdo*(LLMXLN)
C------------------------------------------------------------------------
	CALL ST_NULL ( gdfile, tmpgdi, nt, ier )
	CALL ST_NULL ( gdoutf, tmpgdo, nt, ier )
	CALL DGC_NFIL ( tmpgdi, tmpgdo, iret )
C*
        RETURN
        END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      subroutine spalde(t,n,c,k1,x,d,ier)
c  subroutine spalde evaluates at a point x all the derivatives
c              (j-1)
c      d(j) = s     (x) , j=1,2,...,k1
c  of a spline s(x) of order k1 (degree k=k1-1), given in its b-spline
c  representation.
c
c  calling sequence:
c     call spalde(t,n,c,k1,x,d,ier)
c
c  input parameters:
c    t    : array,length n, which contains the position of the knots.
c    n    : integer, giving the total number of knots of s(x).
c    c    : array,length n, which contains the b-spline coefficients.
c    k1   : integer, giving the order of s(x) (order=degree+1)
c    x    : real, which contains the point where the derivatives must
c           be evaluated.
c
c  output parameters:
c    d    : array,length k1, containing the derivative values of s(x).
c    ier  : error flag
c      ier = 0 : normal return
c      ier =10 : invalid input data (see restrictions)
c
c  restrictions:
c    t(k1) <= x <= t(n-k1+1)
c
c  further comments:
c    if x coincides with a knot, right derivatives are computed
c    ( left derivatives if x = t(n-k1+1) ).
c
c  other subroutines required: fpader.
c
c  references :
c    de boor c : on calculating with b-splines, j. approximation theory
c                6 (1972) 50-62.
c    cox m.g.  : the numerical evaluation of b-splines, j. inst. maths
c                applics 10 (1972) 134-149.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      integer n,k1,ier
      real*8 x
c  ..array arguments..
      real*8 t(n),c(n),d(k1)
c  ..local scalars..
      integer l,nk1
c  ..
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      ier = 10
      nk1 = n-k1
      if(x.lt.t(k1) .or. x.gt.t(nk1+1)) go to 300
c  search for knot interval t(l) <= x < t(l+1)
      l = k1
 100  if(x.lt.t(l+1) .or. l.eq.nk1) go to 200
      l = l+1
      go to 100
 200  if(t(l).ge.t(l+1)) go to 300
      ier = 0
c  calculate the derivatives.
      call fpader(t,n,c,k1,x,l,d)
 300  return
      end

max_stars_repo_name: Ennosigaeon/scipy

max_issues_repo_name: Ennosigaeon/scipy

max_forks_repo_name: Ennosigaeon/scipy


text:
DPI Graphics is a graphic design firm which hires student employees, and is located in Lower Freeborn Hall, right across the way from KDVS.  Most all of the clients for DPI are affiliated with Campus Recreation, which includes Outdoor Adventures, Equestrian Center The Equestrian Center, Rec Pool The Rec Pool, The MU Games Area, The MU Information Center and a lot more.  Although thats not to say that DPI doesnt welcome jobs from people not associated with Campus Recreation, its just that DPI happens to be a part of Campus Rec. and as a result does a lot of designing for them.

There are usually three student workers employed by DPI, although during transitional periods there can be four or even two.  All of them are design students at UC Davis and most seem to last about a year, but some stay upwards of two.

20081221 14:13:20 nbsp Is this now called CUCR Graphics? Users/JasonAller


!-------------------------------------------------------------------------------
!> Module forcing driver
!!
!! @par Description
!!          This module is for the artificial forcing
!!
!! @author NICAM developers, Team SCALE
!<
!-------------------------------------------------------------------------------
module mod_forcing_driver
  !-----------------------------------------------------------------------------
  !
  !++ Used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof

  use mod_adm, only: &
     ADM_LOG_FID
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: forcing_setup
  public :: forcing_step
  public :: forcing_update

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedures
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  integer, private, parameter :: nmax_TEND     = 7
  integer, private, parameter :: nmax_PROG     = 6
  integer, private, parameter :: nmax_v_mean_c = 5

  integer, private, parameter :: I_RHOG     = 1 ! Density x G^1/2 x gamma^2
  integer, private, parameter :: I_RHOGVX   = 2 ! Density x G^1/2 x gamma^2 x Horizontal velocity (X-direction)
  integer, private, parameter :: I_RHOGVY   = 3 ! Density x G^1/2 x gamma^2 x Horizontal velocity (Y-direction)
  integer, private, parameter :: I_RHOGVZ   = 4 ! Density x G^1/2 x gamma^2 x Horizontal velocity (Z-direction)
  integer, private, parameter :: I_RHOGW    = 5 ! Density x G^1/2 x gamma^2 x Vertical   velocity
  integer, private, parameter :: I_RHOGE    = 6 ! Density x G^1/2 x gamma^2 x Internal Energy
  integer, private, parameter :: I_RHOGETOT = 7 ! Density x G^1/2 x gamma^2 x Total Energy

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine forcing_setup
    use mod_adm, only: &
       ADM_proc_stop
    use mod_runconf, only: &
       AF_TYPE
    use mod_af_heldsuarez, only: &
       AF_heldsuarez_init
    implicit none
    !---------------------------------------------------------------------------

    write(ADM_LOG_FID,*)
    write(ADM_LOG_FID,*) '+++ Module[forcing]/Category[nhm]'

    write(ADM_LOG_FID,*) '+++ Artificial forcing type: ', trim(AF_TYPE)
    select case(AF_TYPE)
    case('NONE')
       !--- do nothing
    case('HELD-SUAREZ')
       write(ADM_LOG_FID,*) '+++ HELD-SUAREZ'
       call AF_heldsuarez_init
    case default
       write(ADM_LOG_FID,*) 'xxx unsupported forcing type! STOP.'
       call ADM_proc_stop
    end select

    return
  end subroutine forcing_setup

  !-----------------------------------------------------------------------------
  subroutine forcing_step
    use mod_adm, only: &
       ADM_gall_in, &
       ADM_kall,    &
       ADM_lall,    &
       ADM_kmin,    &
       ADM_kmax
    use mod_time, only: &
       TIME_DTL
    use mod_grd, only: &
       GRD_vz, &
       GRD_Z
    use mod_gmtr, only: &
       GMTR_lat
    use mod_vmtr, only: &
       VMTR_GSGAM2,  &
       VMTR_GSGAM2H, &
       VMTR_PHI
    use mod_runconf, only: &
       AF_TYPE, &
       TRC_VMAX
    use mod_prgvar, only: &
       prgvar_get_in_withdiag, &
       prgvar_set_in
    use mod_gtl, only: &
       GTL_clip_region, &
       GTL_clip_region_1layer
    use mod_bndcnd, only: &
       bndcnd_thermo
    use mod_af_heldsuarez, only: &
       AF_heldsuarez
    use mod_history, only: &
       history_in
    implicit none

    real(RP) :: rhog  (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: rhogvx(ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: rhogvy(ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: rhogvz(ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: rhogw (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: rhoge (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: rhogq (ADM_gall_in,ADM_kall,ADM_lall,TRC_vmax)
    real(RP) :: rho   (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: pre   (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: tem   (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: vx    (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: vy    (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: vz    (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: w     (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: q     (ADM_gall_in,ADM_kall,ADM_lall,TRC_vmax)

    ! forcing tendency
    real(RP) :: fvx(ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: fvy(ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: fvz(ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: fw (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: fe (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: fq (ADM_gall_in,ADM_kall,ADM_lall,TRC_VMAX)

    ! geometry, coordinate
    real(RP) :: gsgam2 (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: gsgam2h(ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: phi    (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: z      (ADM_gall_in,ADM_kall,ADM_lall)
    real(RP) :: lat    (ADM_gall_in,ADM_lall)

    real(RP) :: frhogq(ADM_gall_in,ADM_kall,ADM_lall)

    integer :: l, nq
    !---------------------------------------------------------------------------

    call PROF_rapstart('__Forcing')

    call GTL_clip_region(VMTR_GSGAM2 (:,:,:),gsgam2, 1,ADM_kall)
    call GTL_clip_region(VMTR_GSGAM2H(:,:,:),gsgam2h,1,ADM_kall)
    call GTL_clip_region(VMTR_PHI    (:,:,:),phi,    1,ADM_kall)
    call GTL_clip_region(GRD_vz(:,:,:,GRD_Z),z,      1,ADM_kall)

    call GTL_clip_region_1layer(GMTR_lat(:,:),lat)

    !--- get the prognostic and diagnostic variables
    call prgvar_get_in_withdiag( rhog,   & ! [IN]
                                 rhogvx, & ! [IN]
                                 rhogvy, & ! [IN]
                                 rhogvz, & ! [IN]
                                 rhogw,  & ! [IN]
                                 rhoge,  & ! [IN]
                                 rhogq,  & ! [IN]
                                 rho,    & ! [IN]
                                 pre,    & ! [IN]
                                 tem,    & ! [IN]
                                 vx,     & ! [IN]
                                 vy,     & ! [IN]
                                 vz,     & ! [IN]
                                 w,      & ! [IN]
                                 q       ) ! [IN]

    !--- boundary condition
    do l = 1, ADM_lall
       call bndcnd_thermo( ADM_gall_in, & ! [IN]
                           tem(:,:,l),  & ! [INOUT]
                           rho(:,:,l),  & ! [INOUT]
                           pre(:,:,l),  & ! [INOUT]
                           phi(:,:,l)   ) ! [IN]

       vx(:,ADM_kmax+1,l) = vx(:,ADM_kmax,l)
       vy(:,ADM_kmax+1,l) = vy(:,ADM_kmax,l)
       vz(:,ADM_kmax+1,l) = vz(:,ADM_kmax,l)
       vx(:,ADM_kmin-1,l) = vx(:,ADM_kmin,l)
       vy(:,ADM_kmin-1,l) = vy(:,ADM_kmin,l)
       vz(:,ADM_kmin-1,l) = vz(:,ADM_kmin,l)

       q(:,ADM_kmax+1,l,:) = 0.0_RP
       q(:,ADM_kmin-1,l,:) = 0.0_RP
    enddo

    ! forcing
    select case(AF_TYPE)
    case('HELD-SUAREZ')

       do l = 1, ADM_lall
          call af_HeldSuarez( ADM_gall_in, & ! [IN]
                              lat(:,l),    & ! [IN]
                              pre(:,:,l),  & ! [IN]
                              tem(:,:,l),  & ! [IN]
                              vx (:,:,l),  & ! [IN]
                              vy (:,:,l),  & ! [IN]
                              vz (:,:,l),  & ! [IN]
                              fvx(:,:,l),  & ! [OUT]
                              fvy(:,:,l),  & ! [OUT]
                              fvz(:,:,l),  & ! [OUT]
                              fw (:,:,l),  & ! [OUT]
                              fe (:,:,l)   ) ! [OUT]

          call history_in( 'ml_af_fvx', fvx(:,:,l) )
          call history_in( 'ml_af_fvy', fvy(:,:,l) )
          call history_in( 'ml_af_fvz', fvz(:,:,l) )
          call history_in( 'ml_af_fw',  fw (:,:,l) )
          call history_in( 'ml_af_fe',  fe (:,:,l) )
       enddo
       fq(:,:,:,:) = 0.0_RP

    case default

       fvx(:,:,:) = 0.0_RP
       fvy(:,:,:) = 0.0_RP
       fvz(:,:,:) = 0.0_RP
       fw (:,:,:) = 0.0_RP
       fe (:,:,:) = 0.0_RP

       fq (:,:,:,:) = 0.0_RP

    end select

    rhogvx(:,:,:) = rhogvx(:,:,:) + TIME_DTL * fvx(:,:,:) * rho(:,:,:) * GSGAM2 (:,:,:)
    rhogvy(:,:,:) = rhogvy(:,:,:) + TIME_DTL * fvy(:,:,:) * rho(:,:,:) * GSGAM2 (:,:,:)
    rhogvz(:,:,:) = rhogvz(:,:,:) + TIME_DTL * fvz(:,:,:) * rho(:,:,:) * GSGAM2 (:,:,:)
    rhogw (:,:,:) = rhogw (:,:,:) + TIME_DTL * fw (:,:,:) * rho(:,:,:) * GSGAM2H(:,:,:)
    rhoge (:,:,:) = rhoge (:,:,:) + TIME_DTL * fe (:,:,:) * rho(:,:,:) * GSGAM2 (:,:,:)

    do nq = 1, TRC_VMAX
       frhogq(:,:,:) = fq(:,:,:,nq) * rho(:,:,:) * GSGAM2(:,:,:)

       rhog (:,:,:)    = rhog (:,:,:)    + TIME_DTL * frhogq(:,:,:)
       rhogq(:,:,:,nq) = rhogq(:,:,:,nq) + TIME_DTL * frhogq(:,:,:)
    enddo

    !--- set the prognostic variables
    call prgvar_set_in( rhog,   & ! [IN]
                        rhogvx, & ! [IN]
                        rhogvy, & ! [IN]
                        rhogvz, & ! [IN]
                        rhogw,  & ! [IN]
                        rhoge,  & ! [IN]
                        rhogq   ) ! [IN]

    call PROF_rapend  ('__Forcing')

    return
  end subroutine forcing_step

  !-----------------------------------------------------------------------------
  subroutine forcing_update( &
       PROG, PROG_pl )
    use mod_adm, only: &
       ADM_have_pl, &
       ADM_gall,    &
       ADM_gall_pl, &
       ADM_lall,    &
       ADM_lall_pl, &
       ADM_kall
    use mod_time, only: &
       TIME_DTL
    use mod_grd, only: &
       GRD_Z,    &
       GRD_ZH,   &
       GRD_vz,   &
       GRD_vz_pl
    use mod_gmtr, only: &
       GMTR_lon,    &
       GMTR_lon_pl, &
       GMTR_lat,    &
       GMTR_lat_pl
    use mod_ideal_init, only: &
       DCTEST_type, &
       DCTEST_case
    use mod_af_trcadv, only: & ![add] 20130612 R.Yoshida
       test11_velocity, &
       test12_velocity
    implicit none

    real(RP), intent(inout) :: PROG    (ADM_gall,   ADM_kall,ADM_lall,   nmax_PROG) ! prognostic variables
    real(RP), intent(inout) :: PROG_pl (ADM_gall_pl,ADM_kall,ADM_lall_pl,nmax_PROG)

    real(RP) :: vx     (ADM_gall,   ADM_kall,ADM_lall   ) ! horizontal velocity_x
    real(RP) :: vx_pl  (ADM_gall_pl,ADM_kall,ADM_lall_pl)
    real(RP) :: vy     (ADM_gall,   ADM_kall,ADM_lall   ) ! horizontal velocity_y
    real(RP) :: vy_pl  (ADM_gall_pl,ADM_kall,ADM_lall_pl)
    real(RP) :: vz     (ADM_gall,   ADM_kall,ADM_lall   ) ! horizontal velocity_z
    real(RP) :: vz_pl  (ADM_gall_pl,ADM_kall,ADM_lall_pl)
    real(RP) :: w      (ADM_gall,   ADM_kall,ADM_lall   ) ! vertical velocity
    real(RP) :: w_pl   (ADM_gall_pl,ADM_kall,ADM_lall_pl)

    real(RP), save :: time = 0.0_RP ! for tracer advection test  [add; original by H.Miura] 20130612 R.Yoshida

    integer :: n, k ,l
    !---------------------------------------------------------------------------

    call PROF_rapstart('__Forcing')

    !--- update velocity
    time = time + TIME_DTL

    if ( DCTEST_type == 'Traceradvection' .AND. DCTEST_case == '1-1' ) then

       do l = 1, ADM_lall
       do k = 1, ADM_kall
       do n = 1, ADM_gall
          ! full (1): u,v
          ! half (2): w
          call test11_velocity( time,                   & ![IN]
                                GMTR_lon(n,l),          & ![IN]
                                GMTR_lat(n,l),          & ![IN]
                                GRD_vz  (n,k,l,GRD_Z ), & ![IN]
                                GRD_vz  (n,k,l,GRD_ZH), & ![IN]
                                vx      (n,k,l),        & ![OUT]
                                vy      (n,k,l),        & ![OUT]
                                vz      (n,k,l),        & ![OUT]
                                w       (n,k,l)         ) ![OUT]
       enddo
       enddo
       enddo

       if ( ADM_have_pl ) then
          do l = 1, ADM_lall_pl
          do k = 1, ADM_kall
          do n = 1, ADM_gall_pl
             call test11_velocity( time,                      & ![IN]
                                   GMTR_lon_pl(n,l),          & ![IN]
                                   GMTR_lat_pl(n,l),          & ![IN]
                                   GRD_vz_pl  (n,k,l,GRD_Z ), & ![IN]
                                   GRD_vz_pl  (n,k,l,GRD_ZH), & ![IN]
                                   vx_pl      (n,k,l),        & ![OUT]
                                   vy_pl      (n,k,l),        & ![OUT]
                                   vz_pl      (n,k,l),        & ![OUT]
                                   w_pl       (n,k,l)         ) ![OUT]
          enddo
          enddo
          enddo
       endif

    elseif( DCTEST_type == 'Traceradvection' .AND. DCTEST_case == '1-2' ) then

       do l = 1, ADM_lall
       do k = 1, ADM_kall
       do n = 1, ADM_gall
          ! full (1): u,v
          ! half (2): w
          call test12_velocity( time,                   & ![IN]
                                GMTR_lon(n,l),          & ![IN]
                                GMTR_lat(n,l),          & ![IN]
                                GRD_vz  (n,k,l,GRD_Z ), & ![IN]
                                GRD_vz  (n,k,l,GRD_ZH), & ![IN]
                                vx      (n,k,l),        & ![OUT]
                                vy      (n,k,l),        & ![OUT]
                                vz      (n,k,l),        & ![OUT]
                                w       (n,k,l)         ) ![OUT]
       enddo
       enddo
       enddo

       if ( ADM_have_pl ) then
          do l = 1, ADM_lall_pl
          do k = 1, ADM_kall
          do n = 1, ADM_gall_pl
             call test12_velocity( time,                      & ![IN]
                                   GMTR_lon_pl(n,l),          & ![IN]
                                   GMTR_lat_pl(n,l),          & ![IN]
                                   GRD_vz_pl  (n,k,l,GRD_Z ), & ![IN]
                                   GRD_vz_pl  (n,k,l,GRD_ZH), & ![IN]
                                   vx_pl      (n,k,l),        & ![OUT]
                                   vy_pl      (n,k,l),        & ![OUT]
                                   vz_pl      (n,k,l),        & ![OUT]
                                   w_pl       (n,k,l)         ) ![OUT]
          enddo
          enddo
          enddo
       endif

    endif

    PROG(:,:,:,I_RHOGVX) = vx(:,:,:) * PROG(:,:,:,I_RHOG)
    PROG(:,:,:,I_RHOGVY) = vy(:,:,:) * PROG(:,:,:,I_RHOG)
    PROG(:,:,:,I_RHOGVZ) = vz(:,:,:) * PROG(:,:,:,I_RHOG)
    PROG(:,:,:,I_RHOGW ) = w (:,:,:) * PROG(:,:,:,I_RHOG)

    if ( ADM_have_pl ) then
       PROG_pl(:,:,:,I_RHOGVX) = vx_pl(:,:,:) * PROG_pl(:,:,:,I_RHOG)
       PROG_pl(:,:,:,I_RHOGVY) = vy_pl(:,:,:) * PROG_pl(:,:,:,I_RHOG)
       PROG_pl(:,:,:,I_RHOGVZ) = vz_pl(:,:,:) * PROG_pl(:,:,:,I_RHOG)
       PROG_pl(:,:,:,I_RHOGW ) = w_pl (:,:,:) * PROG_pl(:,:,:,I_RHOG)
    endif

    call PROF_rapend  ('__Forcing')

    return
  end subroutine forcing_update

end module mod_forcing_driver


text:
	SUBROUTINE SNLWSP  ( stnprm, nstnp, rdata, luns, nlun, iret )
C************************************************************************
C* SNLWSP								*
C*									*
C* This subroutine writes the station data to the output devices.	*
C*									*
C* SNLWSP  ( STNPRM, NSTNP, RDATA, LUNS, NLUN, IRET )			*
C*									*
C* Input parameters:							*
C*	STNPRM (NSTNP)	CHAR*		Station parameters		*
C*	NSTNP		INTEGER		Number of station parameters	*
C*	RDATA  (NSTNP)	REAL		Station data values		*
C*	LUNS   (NLUN)	INTEGER		Output LUNS			*
C*	NLUN		INTEGER		Number of output units		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	10/88	GEMPAK 4.1				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	stnprm (*)
	REAL		rdata  (*)
	INTEGER		luns   (*)
C------------------------------------------------------------------------
	iret = 0
C
C*	Write blank line.
C
	DO  i = 1, nlun
	    WRITE  ( luns (i), 1000 )
1000	    FORMAT ( 1X )
	END DO
C
C*	Write out station parameter data.
C
	DO  i = 1, nlun
	    WRITE  ( luns (i), 1010, IOSTAT = iostat )
     +				( stnprm (j), rdata (j), j = 1, nstnp )
1010	    FORMAT ( 4 ( 1X, A4, ' = ', F8.2, 3X ) )
	END DO
C*
	RETURN
	END


!-----------------------------------------------------------------------
!
! MODULE: thrd_comm_module
!> @brief
!> This module contains the subroutines that setup/handle the
!> communications in the presence of threads. This includes making
!> thread sets that allows synchronized, ordered work as wide as the
!> number of threads; assigning groups to threads within these thread
!> sets; and the communication routines themselves.
!
!-----------------------------------------------------------------------

MODULE thrd_comm_module

  USE global_module, ONLY: i_knd, l_knd, r_knd

  USE plib_module, ONLY: nthreads, nnested, plock_omp, ycomm, zcomm,   &
    precv, ylop, yhip, zlop, zhip, firsty, firstz, lasty, lastz,       &
    use_lock, waitall, isend, yproc, zproc

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: assign_thrd_set, destroy_task_set, no_op_lock_control,     &
    sweep_recv_bdry, sweep_send_bdry

  SAVE
!_______________________________________________________________________
!
! Run-time variables
!
! g_off     - group offset for message tags
!_______________________________________________________________________

  INTEGER(i_knd), PARAMETER :: g_off = 2**14

  CONTAINS

  SUBROUTINE assign_thrd_set ( do_task, tlen, tasks_per_thrd,          &
    thrd_set_size, nlen, nstd_set_size, task_act )

!-----------------------------------------------------------------------
!
! Set up thread sets and assign tasks (i.e., groups) to threads.
!  tasks_per_thrd: number of tasks each thread will perform
!  thrd_set_size:  number of threads that will be spawned
!  nstd_set_size:  number of nested threads that will be spawned
!  task_act: the array that tells each thread what to do
!
!-----------------------------------------------------------------------

    INTEGER(i_knd), INTENT(IN) :: tlen, nlen

    INTEGER(i_knd), INTENT(OUT) :: tasks_per_thrd, thrd_set_size,      &
      nstd_set_size

    INTEGER(i_knd), DIMENSION(tlen), INTENT(INOUT) :: do_task

    INTEGER(i_knd), DIMENSION(:,:), POINTER :: task_act
!_______________________________________________________________________
!
!   Local variables
!_______________________________________________________________________

    INTEGER(i_knd) :: ntasks, n, t, next
!_______________________________________________________________________
!
!   Initialize outgoing variables. Set thread set size and number of
!   groups per set. Return if no tasks.
!_______________________________________________________________________

    thrd_set_size  = 0
    nstd_set_size  = 0
    tasks_per_thrd = 0

    ntasks = COUNT( do_task > 0 )
    thrd_set_size = MIN( ntasks, nthreads )

    IF ( thrd_set_size == 0 ) THEN
      ALLOCATE( task_act(0,0) )
      tasks_per_thrd = 0
      nstd_set_size  = 0
      RETURN
    END IF

    tasks_per_thrd = (ntasks-1)/thrd_set_size + 1

    ALLOCATE( task_act(tasks_per_thrd,thrd_set_size) )
    task_act = 0
!_______________________________________________________________________
!
!   Assign tasks to threads in the set sequentially
!_______________________________________________________________________

    n_loop: DO n = 1, tasks_per_thrd
      DO t = 1, thrd_set_size
        next = MAXLOC( do_task, 1 )
        IF ( do_task(next) == 0 ) EXIT n_loop
        task_act(n,t) = next
        do_task(next) = 0
      END DO
    END DO n_loop
!_______________________________________________________________________
!
!   Set the number of nested threads. If provided nlen is zero, apply
!   nested threads to main thread tasks. If nlen is non-zero, set the
!   nested thread set size according to width of nested work.
!_______________________________________________________________________

    IF ( nlen == 0 ) THEN
      nstd_set_size = MIN( tasks_per_thrd, nnested )
    ELSE
      nstd_set_size = MIN( nlen, nnested )
    END IF
!_______________________________________________________________________
!_______________________________________________________________________

  END SUBROUTINE assign_thrd_set

  SUBROUTINE destroy_task_set ( task_act )

!-----------------------------------------------------------------------
!
! Destroy the task_act array allocated in assign_thrd_set. Nullify and
! deallocate the incoming pointer.
!
!-----------------------------------------------------------------------

    INTEGER(i_knd), DIMENSION(:,:), POINTER :: task_act
!_______________________________________________________________________
!
!   Local variables
!_______________________________________________________________________
!_______________________________________________________________________

    DEALLOCATE( task_act )
!_______________________________________________________________________
!_______________________________________________________________________

  END SUBROUTINE destroy_task_set

  SUBROUTINE no_op_lock_control ( t, nthrd )

!-----------------------------------------------------------------------
!
! Control threaded communication that lack thread_multiple thread level
! with locks. If a thread does not have group sweep to perform, must
! still set/unset locks.
!
!-----------------------------------------------------------------------

    INTEGER(i_knd), INTENT(IN) :: t, nthrd
!_______________________________________________________________________
!
!   Local variables
!_______________________________________________________________________

    INTEGER(i_knd) :: nxt
!_______________________________________________________________________
!
!   If locks are unnecessary, return immediately
!_______________________________________________________________________

    IF ( .NOT.use_lock ) RETURN
!_______________________________________________________________________
!
!   Each thread sets its own lock. If a thread's lock is already set, it
!   must wait until another thread unlocks it: work is suspended until
!   it can set its lock and proceed. Then thread unsets next thread's
!   lock.
!_______________________________________________________________________

    CALL plock_omp ( 'set', t )

    nxt = t + 1
    IF ( nxt > nthrd ) nxt = 1
    CALL plock_omp ( 'unset', nxt )
!_______________________________________________________________________
!_______________________________________________________________________

  END SUBROUTINE no_op_lock_control

  SUBROUTINE sweep_recv_bdry ( g, jd, kd, iop, t, nthrd, reqs, szreq,  &
    nc, nang, ichunk, ny, nz, jb_in, kb_in )

!-----------------------------------------------------------------------
!
! Receive jb_in and kb_in flux from upstream boundaries
!
!-----------------------------------------------------------------------

    INTEGER(i_knd), INTENT(IN) :: g, jd, kd, iop, t, nthrd, szreq, nc, &
      nang, ichunk, ny, nz

    INTEGER(i_knd), DIMENSION(szreq), INTENT(INOUT) :: reqs

    REAL(r_knd), DIMENSION(nang,ichunk,nz), INTENT(OUT) :: jb_in

    REAL(r_knd), DIMENSION(nang,ichunk,ny), INTENT(OUT) :: kb_in
!_______________________________________________________________________
!
!   Local variables
!_______________________________________________________________________

    INTEGER(i_knd) :: yp_rcv, zp_rcv, mtag, nxt

    LOGICAL(l_knd) :: incomingy, outgoingy, incomingz, outgoingz
!_______________________________________________________________________
!
!   Determine sender of message and set tag if a message is to be
!   received (g/=0). Tag is set to offset by group, octant, and spatial
!   work chunk.
!_______________________________________________________________________

    IF ( jd == 1 ) THEN
      yp_rcv = yhip
      incomingy = .NOT.lasty
      outgoingy = .NOT.firsty
    ELSE
      yp_rcv = ylop
      incomingy = .NOT.firsty
      outgoingy = .NOT.lasty
    END IF

    IF ( kd == 1 ) THEN
      zp_rcv = zhip
      incomingz = .NOT.lastz
      outgoingz = .NOT.firstz
    ELSE
      zp_rcv = zlop
      incomingz = .NOT.firstz
      outgoingz = .NOT.lastz
    END IF

    mtag = g*g_off + 2*nc*(jd-1 + 2*(kd-1)) + iop
!_______________________________________________________________________
!
!   If locks are used to control threaded communications, each thread
!   sets its own lock. If a thread's lock is already set, it must wait
!   until another thread unlocks it: work is suspended until it can set
!   its lock and proceed.
!_______________________________________________________________________

    IF ( use_lock ) CALL plock_omp ( 'set', t )
!_______________________________________________________________________
!
!   Call to receive upstream data. Call for a wait on previous
!   asynchronous send operations.
!_______________________________________________________________________

    IF ( incomingy ) CALL precv ( yp_rcv, yproc, nang, ichunk, nz,     &
                                  jb_in, ycomm, mtag )
    IF ( incomingz ) CALL precv ( zp_rcv, zproc, nang, ichunk, ny,     &
                                  kb_in, zcomm, mtag )
    IF ( outgoingy .OR. outgoingz ) CALL waitall ( reqs, szreq )
!_______________________________________________________________________
!
!   If locks are used, unset the lock of another thread to allow it to
!   perform its communications
!_______________________________________________________________________

    IF ( use_lock ) THEN
      nxt = t + 1
      IF ( nxt > nthrd ) nxt = 1
      CALL plock_omp ( 'unset', nxt )
    END IF
!_______________________________________________________________________
!_______________________________________________________________________

  END SUBROUTINE sweep_recv_bdry

  SUBROUTINE sweep_send_bdry ( g, jd, kd, iop, t, nthrd, reqs, szreq,  &
    nc, nang, ichunk, ny, nz, jb_out, kb_out )

!-----------------------------------------------------------------------
!
! Send flux to downstream boundaries
!
!-----------------------------------------------------------------------

    INTEGER(i_knd), INTENT(IN) :: g, jd, kd, iop, t, nthrd, szreq, nc, &
      nang, ichunk, ny, nz

    INTEGER(i_knd), DIMENSION(szreq), INTENT(INOUT) :: reqs

    REAL(r_knd), DIMENSION(nang,ichunk,nz), INTENT(IN) :: jb_out

    REAL(r_knd), DIMENSION(nang,ichunk,ny), INTENT(IN) :: kb_out
!_______________________________________________________________________
!
!   Local variables
!_______________________________________________________________________

    INTEGER(i_knd) :: yp_snd, zp_snd, mtag, nxt

    LOGICAL(l_knd) :: outgoingy, outgoingz
!_______________________________________________________________________
!
!   Determine recipient of message and set tag Tag is set to offset by
!   group, octant, and spatial work chunk.
!_______________________________________________________________________

    IF ( jd == 1 ) THEN
      yp_snd = ylop
      outgoingy = .NOT.firsty
    ELSE
      yp_snd = yhip
      outgoingy = .NOT.lasty
    END IF

    IF ( kd == 1 ) THEN
      zp_snd = zlop
      outgoingz = .NOT.firstz
    ELSE
      zp_snd = zhip
      outgoingz = .NOT.lastz
    END IF

    mtag = g*g_off + 2*nc*(jd-1 + 2*(kd-1)) + iop
!_______________________________________________________________________
!
!   If locks are used to control threaded communications, each thread
!   sets its own lock. If a thread's lock is already set, it must wait
!   until another thread unlocks it: work is suspended until it can set
!   its lock and proceed.
!_______________________________________________________________________

    IF ( use_lock ) CALL plock_omp ( 'set', t )
!_______________________________________________________________________
!
!   Call to send data downstream. Use non-blocking send.
!_______________________________________________________________________

    IF ( outgoingy ) CALL isend ( yp_snd, yproc, nang, ichunk, nz,     &
                                  jb_out, ycomm, mtag, reqs(1) )
    IF ( outgoingz ) CALL isend ( zp_snd, zproc, nang, ichunk, ny,     &
                                  kb_out, zcomm, mtag, reqs(2) )
!_______________________________________________________________________
!
!   If locks are used, unset the lock of another thread to allow it to
!   perform its communications
!_______________________________________________________________________

    IF ( use_lock ) THEN
      nxt = t + 1
      IF ( nxt > nthrd ) nxt = 1
      CALL plock_omp ( 'unset', nxt )
    END IF
!_______________________________________________________________________
!_______________________________________________________________________

  END SUBROUTINE sweep_send_bdry

END MODULE thrd_comm_module


        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:59:54 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE WRITE_OUTPUT_SU__genmod
          INTERFACE
            SUBROUTINE WRITE_OUTPUT_SU(X_SOURCE,Z_SOURCE,IREC,          &
     &BUFFER_BINARY,NUMBER_OF_COMPONENTS)
              USE SPECFEM_PAR, ONLY :                                   &
     &          NSTEP,                                                  &
     &          NREC,                                                   &
     &          DELTAT,                                                 &
     &          SEISMOTYPE,                                             &
     &          ST_XVAL,                                                &
     &          NSTEP_BETWEEN_OUTPUT_SEISMOS,                           &
     &          SEISMO_OFFSET,                                          &
     &          SEISMO_CURRENT,                                         &
     &          P_SV,                                                   &
     &          ST_ZVAL,                                                &
     &          SUBSAMP_SEISMOS
              INTEGER(KIND=4) :: NUMBER_OF_COMPONENTS
              REAL(KIND=8) :: X_SOURCE
              REAL(KIND=8) :: Z_SOURCE
              INTEGER(KIND=4) :: IREC
              REAL(KIND=8) :: BUFFER_BINARY(NSTEP_BETWEEN_OUTPUT_SEISMOS&
     &/SUBSAMP_SEISMOS,NREC,NUMBER_OF_COMPONENTS)
            END SUBROUTINE WRITE_OUTPUT_SU
          END INTERFACE
        END MODULE WRITE_OUTPUT_SU__genmod