text:
Name: Carley

Phone Number: (530) 5555555

Office: No office, just a desk

Personality: varied

20080402 19:36:00 nbsp Nice Photography photo. Users/JasonAller

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
Davis Muffin City is Davis newest gourmet bakeries muffin supplier! DMC supplies muffins to hungry UC Davis students, and is hoping to expand soon from baskets and carts to a more permanent location. Lovers of greattasting food and masters of baking, Chefs Ian Wilson and John James Dudek joined forces with the intent to craft the perfect muffin recipes, the most decadent and flavorful muffins imaginable. And they succeeded. Though certain muffins will always be available, the duo will continually expand and modify the Davis Muffin City repertoire, adding seasonal flavors and pushing the boundaries of muffinmaking to its absolute limits.

Note from owners: Right now we are looking to get commercial kitchen space so that you can find our muffins in cafes and stores around town. Until then, were going to be selling them straight to you. If youd like to order muffins for an event, feel free to contact us! Well also be wandering around the campus with muffins for sale, so come meet us!

DMC also caters! We are currently offering up four types of muffins with seasonal flavors being added in as well from time to time, and we can always do special orders too.

BlueberryMaple Muffins – A classic with an added twist. The Grade A maple adds rich flavor and a soft, fluffy texture. Together, blueberries and maple are unstoppable!
Banananut Cranberry Muffins – Banananut muffins are good. Banananut Cranberry muffins made with the besttasting bananas are significantly better!
Decadent Chocolate Muffins – Chocolate chips are for chumps. We use organic cocoa powder and accent the flavor with pieces of chocolate from our favorite organic chocolate bars!
Apple Cinnamon Muffins – Arkansas Black apples, Saigon cinnamon, and a hint of nutmeg combine to make a classic muffin better than ever before.

Call for more information and look for DMC representatives on campus. Theyre approachable, friendly people, just lookin to brighten up your day! Come talk to us, we love it.

20100412 21:56:28 nbsp Mmm, there muffins were delicious.  The two men who made the muffins were also very friendly AND they use good wholesome, mostly organic ingredients.  They also said they get free range organic eggs from the Coop here in davis.  Yeah, delicious, responsibly made food! It was such a nice surprise for them to walk by. (: Users/laurengodla

20100422 00:27:38 nbsp Those muffins look damn good Users/StevenDaubert

20100422 08:31:35 nbsp I need to stop catching up on restaurant/eatery reviews before eating breakfast.  A minute ago I wanted breakfast burritos, now I really want muffins.  Om nom nom! Users/TomGarberson


text:
c
c
c
c     =================================================================
      subroutine claw3ez    ! No arguments
c     =================================================================
c
c     An easy-to-use clawpack driver routine for simple applications
c     Documentation is available at
c                 http://www.amath.washington.edu/~claw/doc.html
c
c     Author: Randall J. LeVeque, Grady I. Lemoine
c
c     Modified July 2013 to use dynamic allocation, new input file
c     format.  Allocation of all the large arrays (aux, q, work) is
c     delayed until the last possible moment in case any of the user
c     code called before them is a memory hog.
c

      implicit double precision (a-h,o-z)

c     F77 way to get OpenMP function declarations
c$    include 'omp_lib.h'

      external bc3,rpn3,rpt3,rptt3,src3,b4step3

      double precision, dimension(:,:,:,:), allocatable :: q, aux
      double precision, dimension(:), allocatable :: work

c
      dimension method(7),dtv(5),cflv(4),nv(2),mthbc(6)
      double precision, dimension(:), allocatable :: tout
      logical rest
c
      common /restrt_block/ tinitial, iframe
c
      integer, dimension(:), allocatable :: mthlim

      logical :: outaux_init_only, output_t0, use_fwaves
      logical :: outaux_always, dt_variable
      integer :: output_format, dimensional_split, outstyle
      integer, dimension(:), allocatable :: iout_q, iout_aux
      integer :: allocate_status

      call opendatafile(55, 'claw.data')
      open(10,file='fort.info',status='unknown',form='formatted')
c
c
c     # Read the input in standard form from claw2ez.data:

      read(55,*) ndim    ! Not actually used, but the modern Python setup writes it
      read(55,*) xlower, ylower, zlower
      read(55,*) xupper, yupper, zupper
      read(55,*) mx, my, mz
      read(55,*) meqn
      read(55,*) mwaves
      read(55,*) maux
      read(55,*) t0

      read(55,*) outstyle
      if (outstyle.eq.1) then
         read(55,*) nout
         read(55,*) tfinal
         read(55,*) output_t0    ! Not currently used
         nstepout = 1
      else if (outstyle.eq.2) then
         read(55,*) nout
         allocate(tout(nout), stat=allocate_status)
         if (allocate_status .ne. 0) then
            print *, '*** Error allocating tout array; exiting claw3ez'
            go to 900
         end if
         read(55,*) (tout(i), i=1,nout)
         nstepout = 1
      else if (outstyle.eq.3) then
         read(55,*) nstepout
         read(55,*) nstop
         read(55,*) output_t0
         nout = nstop
      else
         print *, '*** Unrecognized output style ', outstyle
         print *, '*** Exiting claw3ez'
         go to 900
      end if

      read(55,*) output_format    ! Not used yet
      ! These iout variables are not currently used, but hang onto them
      ! anyway in case somebody wants to use them at a future date.  The
      ! same goes for outaux_init_only.
      allocate(iout_q(meqn), stat=allocate_status)
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating iout_q array; exiting claw3ez'
         go to 900    ! Exception handling, old school style
      end if
      read(55,*) (iout_q(i), i = 1, meqn)
      if (maux > 0) then
         allocate(iout_aux(maux), stat=allocate_status)
         if (allocate_status .ne. 0) then
            print *, '*** Error allocating iout_aux array;',
     &               ' exiting claw3ez'
            go to 900
         end if
         read(55,*) (iout_aux(i), i = 1, maux)
         read(55,*) outaux_init_only
         ! Not implementing selective output of aux fields yet
         if (any(iout_aux .ne. 0)) then
            outaux_always = .not. outaux_init_only
         else
            outaux_always = .false.
            outaux_init_only = .false.
         end if
      else
         outaux_always = .false.
         outaux_init_only = .false.    ! Just for the sake of initialization
      end if

      read(55,*) dtv(1)     ! Initial dt
      read(55,*) dtv(2)     ! Max dt
      read(55,*) cflv(1)    ! Max CFL number
      read(55,*) cflv(2)    ! Desired CFL number
      read(55,*) nv(1)      ! Maximum number of steps

      read(55,*) dt_variable  ! Variable or fixed dt
      if (dt_variable) then
         method(1) = 1
      else
         method(1) = 0
      end if
      read(55,*) method(2)    ! Order
      read(55,*) method(3)    ! Transverse propagation style
      read(55,*) dimensional_split    ! Whether to use dimensional splitting

      ! Translate new-style Python specification of transverse
      ! order/dimensional splitting into something the older code
      ! understands.
      if (dimensional_split > 0) method(3) = -1

      read(55,*) method(4)    ! Verbosity
      read(55,*) method(5)    ! Source term splitting style
      read(55,*) method(6)    ! Index into aux for capacity function
      method(7) = maux    ! Number of aux variables

      read(55,*) use_fwaves

      allocate(mthlim(mwaves), stat=allocate_status)
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating mthlim array; exiting claw3ez'
         go to 900
      end if
      read(55,*) (mthlim(i), i = 1, mwaves)

      read(55,*) mbc
      read(55,*) mthbc(1), mthbc(3), mthbc(5)
      read(55,*) mthbc(2), mthbc(4), mthbc(6)

      rest = .false.
      read(55, *, err=199, end=199) rest
      if (rest) then
         print *, 'Doing a restart run'
         print *, 'Attempting to read restart frame number'
         print *, 'You may need to hand-edit claw.data'
         read(55,*) iframe      ! restart from data in fort.qN file, N=iframe
         print *, 'Planning restart from frame ', iframe
      end if
 199  continue

      close(unit=55)

      if ((mthbc(1).eq.2 .and. mthbc(2).ne.2) .or.
     &    (mthbc(2).eq.2 .and. mthbc(1).ne.2)) then
         write(6,*) '*** ERROR ***  periodic boundary conditions'
         write(6,*) 'require mthbc(1) and mthbc(2) BOTH be set to 2'
         go to 900
         endif

      if ((mthbc(3).eq.2 .and. mthbc(4).ne.2) .or.
     &    (mthbc(4).eq.2 .and. mthbc(3).ne.2)) then
         write(6,*) '*** ERROR ***  periodic boundary conditions'
         write(6,*) 'require mthbc(3) and mthbc(4) BOTH be set to 2'
         go to 900
         endif

      if ((mthbc(5).eq.2 .and. mthbc(6).ne.2) .or.
     &    (mthbc(6).eq.2 .and. mthbc(5).ne.2)) then
         write(6,*) '*** ERROR ***  periodic boundary conditions'
         write(6,*) 'require mthbc(5) and mthbc(6) BOTH be set to 2'
         go to 900
         endif

c
c     # Figure out how much work space is necessary
c
      if (method(5).lt.2) then
          narray = 1   !# only need one qwork array
        else
          narray = 2   !# need two qwork arrays for Strang splitting
        endif

      maxm = max0(mx, my, mz)
      nthreads=1    ! Serial
c$omp parallel
c$omp single
c$    nthreads = omp_get_num_threads()
c$    maxthreads = omp_get_max_threads()
c$omp end single
c$omp end parallel
      mwork = (maxm+2*mbc)*(46*meqn + mwaves + meqn*mwaves
     &                     + 9*maux + 3)*nthreads
     &         + narray * (mx + 2*mbc) * (my + 2*mbc)
     &                  * (mz + 2*mbc) * meqn

c
c

      call chkmth(method,info)
      if( info .eq. 6) then
         print *, '*** Error in method data; exiting claw3ez'
         go to 900
      end if
c
c
      write(6,*) 'running...'
      write(6,*) ' '
c
c     # grid spacing
      dx = (xupper - xlower) / float(mx)
      dy = (yupper - ylower) / float(my)
      dz = (zupper - zlower) / float(mz)
c

c     # time increments between outputing solution:
      if (outstyle .eq. 1) then
         dtout = (tfinal - t0)/float(nout)
      endif
c
c
c     # call user's routine setprob to set any specific parameters
c     # or other initialization required.
c
      call setprob

c     # Allocate aux
      if (maux > 0) then
         allocate(aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc, 1-mbc:mz+mbc),
     &            stat=allocate_status)
      else
         ! Allocate a dummy array so that dereferencing it doesn't cause
         ! a segfault.  This may not be necessary.
         allocate(aux(1,1,1,1), stat=allocate_status)
      end if
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating aux array; exiting claw3ez'
         go to 900
      end if
c
c     # set aux array:
c
      if (maux .gt. 0)  then
         call setaux(mbc,mx,my,mz,xlower,ylower,
     &               zlower,dx,dy,dz,maux,aux)
         endif

c     # Allocate q
      allocate(q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc, 1-mbc:mz+mbc),
     &         stat=allocate_status)
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating q array; exiting claw3ez'
         go to 900
      end if

c
c     # set initial conditions:

      if (rest) then
          call restart(meqn,mbc,mx,my,mz,
     &          xlower,ylower,zlower,dx,dy,dz,q)
          t0 = tinitial
        else
          call qinit(meqn,mbc,mx,my,mz,xlower,
     &           ylower,zlower,dx,dy,dz,q,maux,aux)
          iframe = 0
        endif
c
c
c
      if (.not. rest) then
c        # output initial data
         call out3(meqn,mbc,mx,my,mz,xlower,ylower,
     &          zlower,dx,dy,dz,q,t0,iframe,aux,maux,
     &          outaux_init_only .or. outaux_always)
         write(6,601) iframe, t0
         endif

      ! Allocate work array
      allocate(work(mwork), stat=allocate_status)
      if (allocate_status .ne. 0) then
         print *, '*** Error (nthreads=',nthreads,
     &        ') allocating work array; exiting claw3ez'
         go to 900
      end if

c
c     ----------
c     Main loop:
c     ----------
c
      tend = t0
      n0   = iframe*nstepout + 1

      do 100 n=n0,nout
         tstart = tend
         if (outstyle .eq. 1)  tend = tstart + dtout
         if (outstyle .eq. 2)  tend = tout(n)
         if (outstyle .eq. 3)  tend = tstart - 1.d0  !# single-step mode
c
         call claw3(meqn,mwaves,mbc,mx,my,mz,maux,
     &           q,aux,xlower,ylower,zlower,dx,dy,dz,tstart,tend,dtv,
     &           cflv,nv,method,mthlim,mthbc,
     &           work,mwork,use_fwaves,info,bc3,rpn3,rpt3,rptt3,src3,
     &           b4step3)
c
c        # check to see if an error occured:
         if (info .ne. 0) then
            write(6,*) 'claw3ez aborting: Error return from claw3',
     &                 ' with info =',info
            go to 900
            endif
c
         dtv(1) = dtv(5)  !# use final dt as starting value on next call
c
c        # output solution at this time
c        ------------------------------
c
c        # if outstyle=1 or 2, then nstepout=1 and we output every time
c        # we reach this point, since claw1 was called for the entire time
c        # increment between outputs.
c
c        # if outstyle=3 then we only output if we have taken nstepout
c        # time steps since the last output.

c        # iframe is the frame number used to form file names in out3
         if (mod(n,nstepout) .eq. 0) then
            iframe = iframe + 1
            call out3(meqn,mbc,mx,my,mz,xlower,ylower,
     &            zlower,dx,dy,dz,q,tend,iframe,aux,maux,
     &            outaux_always)
            write(6,601) iframe,tend
            write(10,1010) tend,info,dtv(3),dtv(4),dtv(5),
     &           cflv(3),cflv(4),nv(2)
            endif

c
c        # formats for writing out information about this call to claw:

  601    format('CLAW3EZ: Frame ',i4,
     &         ' matlab plot files done at time t =',
     &         d12.4,/)
c
 1010    format('tend =',d15.4,/,
     &       'info =',i5,/,'smallest dt =',d15.4,/,'largest dt =',
     &       d15.4,/,'last dt =',d15.4,/,'largest cfl =',
     &         d15.4,/,'last cfl =',d15.4,/,'steps taken =',i4,/)
c
  100    continue
c
 900  continue
c
      ! Destructor, old school style
      if (allocated(work))     deallocate(work)
      if (allocated(q))        deallocate(q)
      if (allocated(aux))      deallocate(aux)
      if (allocated(mthlim))   deallocate(mthlim)
      if (allocated(iout_aux)) deallocate(iout_aux)
      if (allocated(iout_q))   deallocate(iout_q)
      if (allocated(tout))     deallocate(tout)

      return
      end

max_stars_repo_name: ClimateImpactLab/classic

max_issues_repo_name: ClimateImpactLab/classic

max_forks_repo_name: cjvogl/classic


module derived_parameters
    use input
    use global_variables
    implicit none
    contains

	!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!!!!!!!!!!!!!!!!!!!!!!!

    subroutine derived_param()
        implicit none
        integer :: i
        call read_inputfile()
        ! gas derived parameters
        lm = lm_ref*(temp/298)*(101325/p)*(1+(S_ref/298))/(1+(S_ref/temp)) ! mean free path (m)
        mu = mu_g_ref*((298+S_ref)/(temp+S_ref))*((temp/298)**(1.5)) ! viscosity (pa.s)

        m1 = Mw_p/NA ! molecular mass
        vm = m1/rho_p ! molecular volume
    end subroutine derived_param

	!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!!!!!!!!!!!!!!!!!!!!!!!

    double precision function beta(v1,v2)
		implicit none
        double precision, intent(in) :: v1, v2
		double precision :: dc1, dc2, Kn1, Kn2, D1, D2, c1, c2, l1, l2, g1, g2
		call read_inputfile()

        dc1 = (6*v1/PI)**(1.0/3)
        dc2 = (6*v2/PI)**(1.0/3)
        Kn1 = 2*lm_ref/dc1
		Kn2 = 2*lm_ref/dc2

        D1 = (KB*Temp/(3*PI*mu_g_ref*dc1))*((5+4*Kn1+6*(Kn1**2)+18*(Kn1**3))/(5-Kn1+(8+PI)*(Kn1**2)))
        D2 = (KB*Temp/(3*PI*mu_g_ref*dc2))*((5+4*Kn2+6*(Kn2**2)+18*(Kn2**3))/(5-Kn2+(8+PI)*(Kn2**2)))
		c1 = ((8*KB*Temp)/(PI*rho_p*v1))**(0.5)
        c2 = ((8*KB*Temp)/(PI*rho_p*v2))**(0.5)

		l1 = 8*D1/(PI*c1)
        l2 = 8*D2/(PI*c2)

		g1 = (1/(3*dc1*l1))*(((dc1+l1)**3) +((dc1*dc1+l1*l1)**(3/2))) - dc1
        g2 = (1/(3*dc2*l2))*(((dc2+l2)**3) +((dc2*dc2+l2*l2)**(3/2))) - dc2

		beta = 2*PI*(D1+D2)*(dc1+dc2)*((((dc1+dc2)/(dc1+dc2 + 2*((g1**2 + g2**2)**(0.5)))) + (8*(D1+D2)/((((c1**2 + c2**2)**(0.5)))*(dc1+dc2))))**(-1))
    end function beta

	!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!!!!!!!!!!!!!!!!!!!!!!!

	function fractn(N_modes,vk) ! COAGULATION- REDISTRIBUTION OF PARTICLE BETWEEN BINS
		implicit none
        integer, intent(in) :: N_modes
		double precision, intent(in) :: vk(N_modes)
		double precision :: fractn(N_modes,N_modes,N_modes)
		double precision :: v_new(N_modes,N_modes), sum(N_modes,N_modes), L, R
		integer :: i, j, k, flag
		! v_new(i,j) gives the the new volume of particle when particles in mode i and j collide
		! sum(i,j) gives the mode whose volume is least smaller than v(i) + v(j)
		! L is a dummy variable

		sum = 0
		do i = 1, N_modes
			do j = 1, N_modes
				v_new(i,j) = vk(i) + vk(j)
				do k = 1, N_modes
					IF (vk(k) < v_new(i,j)) THEN
						flag = 1
					ELSE
						flag = 0
					END IF
					sum(i,j) = sum(i,j) + flag
				end do
				! Now, sum(i,j) = mode # whose volume is least smaller than v(i) + v(j)
			end do
        end do

		fractn = 0
		do i = 1, N_modes
			do j = 1, N_modes
				L = sum(i,j)
				IF (L == N_modes) THEN
					fractn(i,j,L)=1
				ELSE
					R = vk(L+1)/vk(L)
					fractn(i,j,L)=(R*vk(L)-v_new(i,j))/((R-1)*vk(L))
					fractn(i,j,L+1)= (v_new(i,j)-vk(L))/((R-1)*vk(L))
				END IF
			end do
		end do
    end function fractn

	!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!!!!!!!!!!!!!!!!!!!!!!!
end module derived_parameters


text:
*
*
      subroutine timpot(lmax)
*
*
*       determine changes to the system due to changes of mass distribution
*       -------------------------------------------------------------------
*
*     timpot is called before interaction sequence (intb3b3 - intb3f - formb3)
*     so ikind cannot be negative
*
*
      include 'common.h'
*
c      real*8 uoo,uon,uno,unn,vold,vnew,dd,v2t,vrp,vtp
      real*8 uoo,uon,uno,unn,vold,vnew,dd,v2t
*
      integer lmax,i,k1,k2,im,imo,ipo,iex,im1
*
c      common /timep/ vrp(nmax),vtp(nmax)
*
      do 10 i=1,lmax
         im = iname(i)
         imo = inameo(i)
*
*     determine old potentials for old and new positions
*
         uoo = uo(imo)
         ipo = 1
         k1 = 1
         k2 = lmax
         call potent(ipo,k1,k2,r(i),uon)
*
*     determine new potentials for old and new positions
*
         ipo = 0
         k1 = 1
         k2 = lmax
         call potent(ipo,k1,k2,ro(imo),uno)
         unn = u(i)
*
*     determine old and new velocities
*
         vold = vro(im)*vro(im) + vto(im)*vto(im)
         vnew = vold + uoo - uon - unn + uno
*
*     determine new radial and tangential velocities
*
         vt(im) = vto(im)*ro(imo)/r(i)
         v2t = vt(im)*vt(im)
         dd = vnew - v2t
         if(body(im).lt.0.d0) then
           write(6,*) ' m < 0  i,im,imo,m = ',i,im,imo,body(im)
           stop ' mass < 0 '
         endif
*
         if(dd.gt.0.0d0) then
           vr(im) = sqrt(dd)
           vrr(im) = 0.0d0
         else
*
           if(vnew.lt.0.0d0) then
             vr(im) = 0.0d0
             vrr(im) = 0.5d0*dd*body(im)
           else
             dd = xmax(im)/r(i) - 1.0d0
             v2t = r(i)/xmin(im) - 1.0d0
             if((dd.lt.0.03d0).or.(v2t.lt.0.03d0)) then
               vr(im) = 0.0d0
               vt(im) = sqrt(vnew)
               vrr(im) = 0.0d0
             else
               dd = vrp(im)**2 + vtp(im)**2
               dd = sqrt(dd/vnew)
               vr(im) = 0.0d0
               vt(im) = sqrt(vnew)
               vr(im) = vrp(im)/dd
               vt(im) = vtp(im)/dd
               vrr(im)= 0.0d0
             endif
           endif
         endif
*
*     for the nminzo stars the velocities are artificialy isotropised
*
c 20      continue
c  20     iex = 3*nminzo
c  20     iex = 0.1*nt
         iex = -10
         if(i.le.iex) then
         im1 = iname(i)
         if(ikind(im1).lt.0) then
           print*,'timpot: i,im1,ikind = ',i,im1,ikind(im1)
         endif
           if(ikind(im1).eq.2) go to 10
           dd = (vr(im)**2 + vt(im)**2)/3.0d0
           vr(im) = sqrt(dd)
           vt(im) = sqrt(2.0d0*dd)
         endif
*
 10   continue
*
*
      return
*
      end
*
*
*

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse


!***********************************************************************************************************************************
!**                                     S U B R O U T I N E    G R E G O R I A N   D A T E                                        **
!***********************************************************************************************************************************

SUBROUTINE GREGORIAN_DATE
  USE GDAYC
  IMPLICIT NONE
  INTEGER :: INCR

! Determine if new year (regular or leap) and increment year

  DO WHILE (JDAYG >= 366)
    IF (.NOT. LEAP_YEAR .AND. JDAYG >= 366) THEN
      JDAYG     = JDAYG-365
      YEAR      = YEAR+1
      LEAP_YEAR = MOD(YEAR,4) == 0
    ELSE IF (JDAYG >= 367) THEN
      JDAYG     = JDAYG-366
      YEAR      = YEAR+1
      LEAP_YEAR = MOD(YEAR,4) == 0
    ELSE
      EXIT
    END IF
  END DO
  INCR = 0
  IF (LEAP_YEAR) INCR = 1

! Determine month and day of year

  IF (JDAYG >= 1 .AND. JDAYG < 32) THEN
    GDAY  = JDAYG
    DAYM  = 31.0
    MONTH = '  January'
    IMON  = 1
  ELSE IF (JDAYG >= 32 .AND. JDAYG < 60+INCR) THEN
    GDAY  = JDAYG-31
    DAYM  = 29.0
    MONTH = ' February'
    IMON  = 2
  ELSE IF (JDAYG >= 60 .AND. JDAYG < 91+INCR) THEN
    GDAY  = JDAYG-59-INCR
    DAYM  = 31.0
    MONTH = '    March'
    IMON = 3
  ELSE IF (JDAYG >= 91 .AND. JDAYG < 121+INCR) THEN
    GDAY  = JDAYG-90-INCR
    DAYM  = 30.0
    MONTH = '    April'
    IMON  = 4
  ELSE IF (JDAYG >= 121 .AND. JDAYG < 152+INCR) THEN
    GDAY  = JDAYG-120-INCR
    DAYM  = 31.0
    MONTH = '      May'
    IMON     = 5
  ELSE IF (JDAYG >= 152 .AND. JDAYG < 182+INCR) THEN
    GDAY  = JDAYG-151-INCR
    DAYM  = 30.0
    MONTH = '     June'
    IMON     = 6
  ELSE IF (JDAYG >= 182 .AND. JDAYG < 213+INCR) THEN
    GDAY  = JDAYG-181-INCR
    DAYM  = 31.0
    MONTH = '     July'
    IMON     = 7
  ELSE IF (JDAYG >= 213 .AND. JDAYG < 244+INCR) THEN
    GDAY  = JDAYG-212-INCR
    DAYM  = 31.0
    MONTH = '   August'
    IMON     = 8
  ELSE IF (JDAYG >= 244 .AND. JDAYG < 274+INCR) THEN
    GDAY  = JDAYG-243-INCR
    DAYM  = 30.0
    MONTH = 'September'
    IMON     = 9
  ELSE IF (JDAYG >= 274 .AND. JDAYG < 305+INCR) THEN
    GDAY  = JDAYG-273-INCR
    DAYM  = 31.0
    MONTH = '  October'
    IMON     = 10
  ELSE IF (JDAYG >= 305 .AND. JDAYG < 335+INCR) THEN
    GDAY  = JDAYG-304-INCR
    DAYM  = 30.0
    MONTH = ' November'
    IMON     = 11
  ELSE IF (JDAYG >= 335 .AND. JDAYG < 366+INCR) THEN
    GDAY  = JDAYG-334-INCR
    DAYM  = 31.0
    MONTH = ' December'
    IMON     = 12
  END IF
END SUBROUTINE GREGORIAN_DATE


text:
! This test was created from ..\problem-specifications\exercises\triangle\canonical-data.json
!

program triangle_test_main
  use TesterMain
  use triangle
  implicit none

  ! Test 1: all sides are equal
  call assert_equal(.true., equilateral([2, 2, 2]), "all sides are equal")
  ! Test 2: any side is unequal
  call assert_equal(.false., equilateral([2, 3, 2]), "any side is unequal")
  ! Test 3: no sides are equal
  call assert_equal(.false., equilateral([5, 4, 6]), "no sides are equal")
  ! Test 4: all zero sides is not a triangle
  call assert_equal(.false., equilateral([0, 0, 0]), "all zero sides is not a triangle")
  ! Test 5: sides may be floats
  call assert_equal(.true., equilateral([0.5, 0.5, 0.5]), "sides may be floats")
  ! Test 1: last two sides are equal
  call assert_equal(.true., isosceles([3, 4, 4]), "last two sides are equal")
  ! Test 2: first two sides are equal
  call assert_equal(.true., isosceles([4, 4, 3]), "first two sides are equal")
  ! Test 3: first and last sides are equal
  call assert_equal(.true., isosceles([4, 3, 4]), "first and last sides are equal")
  ! Test 4: equilateral triangles are also isosceles
  call assert_equal(.true., isosceles([4, 4, 4]), "equilateral triangles are also isosceles")
  ! Test 5: no sides are equal
  call assert_equal(.false., isosceles([2, 3, 4]), "no sides are equal")
  ! Test 6: first triangle inequality violation
  call assert_equal(.false., isosceles([1, 1, 3]), "first triangle inequality violation")
  ! Test 7: second triangle inequality violation
  call assert_equal(.false., isosceles([1, 3, 1]), "second triangle inequality violation")
  ! Test 8: third triangle inequality violation
  call assert_equal(.false., isosceles([3, 1, 1]), "third triangle inequality violation")
  ! Test 9: sides may be floats
  call assert_equal(.true., isosceles([0.5, 0.4, 0.5]), "sides may be floats")
  ! Test 1: no sides are equal
  call assert_equal(.true., scalene([5, 4, 6]), "no sides are equal")
  ! Test 2: all sides are equal
  call assert_equal(.false., scalene([4, 4, 4]), "all sides are equal")
  ! Test 3: two sides are equal
  call assert_equal(.false., scalene([4, 4, 3]), "two sides are equal")
  ! Test 4: may not violate triangle inequality
  call assert_equal(.false., scalene([7, 3, 2]), "may not violate triangle inequality")
  ! Test 5: sides may be floats
  call assert_equal(.true., scalene([0.5, 0.4, 0.6]), "sides may be floats")

  call test_report()

end program

max_stars_repo_name: zmoon/fortran

max_issues_repo_name: zmoon/fortran

max_forks_repo_name: zmoon/fortran


text:
      PROGRAM SCALE

!***********************************************************************
!* Scales UDS Files
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 2003/07/18
!***********************************************************************

      ! Headers
      INCLUDE 'uds_str.fi'
      INCLUDE 'uds_fxn.fi'
      INCLUDE 'file.fi'

      ! Variables ______________________________________________________

      RECORD /UDS/  U
      RECORD /UDS_CONTROL/  C
      RECORD /FILE/  HIT, REPORT, OUTPUT_LIST

      LOGICAL ALL_BATCH, NO_BATCH, NO_INCR, ONE_PASS, NEW_HIT, EOF,
     & BATCH, GROUP, NEW_GROUP, NO_FLAG

      INTEGER NUM_ARGS, MAX_ARGS, IOS, IOS_W, I

      PARAMETER ( MAX_ARGS = 12 )

      DOUBLE PRECISION SFAC_CL, SFAC

      CHARACTER CL_ARG(0:MAX_ARGS)*255, PROG_NAME*8,
     & TEMPLATE_STR*255, DIR_OUT*255,
     & FILE_NAME*255, OUT_FILE*255, DEF_FILE*255,
     & PROMPT*79,
     & AXIS_CL, TYPE_CL*20, UNITS_CL*20,
     & AXIS, SFAC_C*25, TYPE*20, UNITS*20

      ! Initializations
      PROG_NAME = 'Scale'
      CALL FILE_INIT( HIT )
      CALL GET_CL( CL_ARG, NUM_ARGS, MAX_ARGS )
      CALL SCALE_CL( CL_ARG, NUM_ARGS, PROG_NAME,
     & AXIS_CL, SFAC_CL, TYPE_CL, UNITS_CL, NO_FLAG )
      CALL PROC_CL( CL_ARG, NUM_ARGS, PROG_NAME, TEMPLATE_STR,
     & ALL_BATCH, NO_BATCH, NO_INCR, REPORT, OUTPUT_LIST, DIR_OUT,
     & ONE_PASS, .TRUE., .TRUE. )
      PROMPT = 'UDS file name/template/hitlist?'
      PROMPT(74:) = '[done]'
      CALL UDS_CONTROL_INIT( C )

      WRITE( *, '(//27X,A//)' ) '**  Scale UDS Files  **'

      ! Read the file name/template/hitlist
  100 CALL FILE_PROMPT( TEMPLATE_STR, PROMPT, DIR_OUT,
     & ONE_PASS, HIT, NEW_HIT, FILE_NAME, EOF )
      IF ( ( FILE_NAME .EQ. ' ' ) .OR. ( EOF ) ) GO TO 199 ! Done

      ! Batch setup
      CALL BAT_SET( ALL_BATCH, NO_BATCH, NEW_HIT, HIT, BATCH )
      CALL GROUP_SET( HIT, NEW_HIT, BATCH, 2, GROUP, NEW_GROUP )

      ! Group prompts
      IF ( NEW_GROUP ) THEN

        ! Get axis
  101   IF ( AXIS_CL .EQ. ' ' ) THEN
          WRITE( *, '(/A,54X,A/'' >> '',$)' )
     &       ' Axis to scale?   (X/Y)', '[Y]'
          READ( *, '(A)', IOSTAT=IOS ) AXIS
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          CALL STR_UP( AXIS )
          IF ( .NOT. ANY_CHARS( AXIS, ' XY' ) ) THEN
            WRITE( *, * ) '*** Invalid response'
            GO TO 101
          END IF
          IF ( AXIS .EQ. ' ' ) AXIS = 'Y'
        ELSE
          AXIS = AXIS_CL
        END IF

        ! Get scale factor
  102   IF ( SFAC_CL .EQ. 0.D0 ) THEN
          WRITE( *, '(/A/'' >> '',$)' ) ' Scale factor?'
          READ( *, '(A)', IOSTAT=IOS ) SFAC_C
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          READ( SFAC_C, '(BN,F25.0)', IOSTAT=IOS ) SFAC
          IF ( ( IOS .NE. 0 ) .OR. ( SFAC_C .EQ. ' ' ) ) THEN
            WRITE( *, * ) '*** Invalid scale factor'
            GO TO 102
          END IF
        ELSE
          SFAC = SFAC_CL
        END IF

        ! Get new data type
        IF ( TYPE_CL .EQ. ' ' ) THEN
          WRITE( *, '(/A,51X,A/'' >> '',$)' )
     &       ' Output data type?', '[no change]'
          READ( *, '(A)', IOSTAT=IOS ) TYPE
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          CALL STR_UP( TYPE )
        ELSE IF ( TYPE_CL .NE. 'no_change' ) THEN
          TYPE = TYPE_CL
        ELSE
          TYPE = ' '
        END IF

        ! Get new units
        IF ( UNITS_CL .EQ. ' ' ) THEN
          WRITE( *, '(/A,55X,A/'' >> '',$)' )
     &     ' Output units?', '[no change]'
          READ( *, '(A)', IOSTAT=IOS ) UNITS
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          CALL STR_UP( UNITS )
        ELSE IF ( UNITS_CL .NE. 'no_change' ) THEN
          UNITS = UNITS_CL
        ELSE
          UNITS = ' '
        END IF

      END IF

      ! Read UDS file
      CALL REP_COLS( REPORT )
      CALL UDS_GET( FILE_NAME, U, C, REPORT, IOS )
      IF ( IOS .NE. 0 ) GO TO 190

      IF ( .NOT. GROUP ) THEN ! Interactive prompts

        ! Get axis
  103   IF ( AXIS_CL .EQ. ' ' ) THEN
          WRITE( *, * )
          WRITE( *, * ) '  X-axis is ', U.XTYP(:L_TRIM(U.XTYP)),
     &     ' ('//U.XUNITS(:L_TRIM(U.XUNITS))//')'
          WRITE( *, * ) '  Y-axis is ', U.YTYP(:L_TRIM(U.YTYP)),
     &     ' ('//U.YUNITS(:L_TRIM(U.YUNITS))//')'
          WRITE( *, '(/A,54X,A/'' >> '',$)' )
     &     ' Axis to scale?   (X/Y)', '[Y]'
          READ( *, '(A)', END=190 ) AXIS
          CALL STR_UP( AXIS )
          IF ( .NOT. ANY_CHARS( AXIS, ' XY' ) ) THEN
            WRITE( *, * ) '*** Invalid response'
            GO TO 103
          END IF
          IF ( AXIS .EQ. ' ' ) AXIS = 'Y'
        ELSE
          AXIS = AXIS_CL
        END IF

        ! Get scale factor
  104   IF ( SFAC_CL .EQ. 0.D0 ) THEN
          WRITE( *, '(/A/'' >> '',$)' ) ' Scale factor?'
          READ( *, '(A)', END=190 ) SFAC_C
          READ( SFAC_C, '(BN,F25.0)', IOSTAT=IOS ) SFAC
          IF ( ( IOS .NE. 0 ) .OR. ( SFAC_C .EQ. ' ' ) ) THEN
            WRITE( *, * ) '*** Invalid scale factor'
            GO TO 104
          END IF
        ELSE
          SFAC = SFAC_CL
        END IF

        ! Get new data type
        IF ( TYPE_CL .EQ. ' ' ) THEN
          IF ( AXIS .EQ. 'X' ) THEN
            TYPE = U.XTYP
          ELSE
            TYPE = U.YTYP
          END IF
          WRITE( *, '(/A,40X,A/'' >> '',$)' )
     &     ' Output data type?', '['//TYPE//']'
          READ( *, '(A)', END=190 ) TYPE
          CALL STR_UP( TYPE )
        ELSE IF ( TYPE_CL .NE. 'no_change' ) THEN
          TYPE = TYPE_CL
        ELSE
          TYPE = ' '
        END IF

        ! Get new units
        IF ( UNITS_CL .EQ. ' ' ) THEN
          IF ( AXIS .EQ. 'X' ) THEN
            UNITS = U.XUNITS
          ELSE
            UNITS = U.YUNITS
          END IF
          WRITE( *, '(/A,44X,A/'' >> '',$)' )
     &     ' Output units?', '['//UNITS//']'
          READ( *, '(A)', END=190 ) UNITS
          CALL STR_UP( UNITS )
        ELSE IF ( UNITS_CL .NE. 'no_change' ) THEN
          UNITS = UNITS_CL
        ELSE
          UNITS = ' '
        END IF

      END IF

      ! Perform scaling
      IF ( AXIS .EQ. 'X' ) THEN
        IF ( U.CHANFORM .EQ. 'X-Y' ) THEN
          DO I = U.NFP, U.NLP
            U.X(I) = REAL( U.X(I) * SFAC )
          END DO
        END IF
        IF ( U.DEL .NE. 0. ) U.DEL = REAL( U.DEL * SFAC )
      ELSE
        DO I = U.NFP, U.NLP
          U.Y(I) = REAL( U.Y(I) * SFAC )
        END DO
      END IF

      ! Prepare output fields
      U.STATUS = 'SCALED'
      U.HIC = 0.
      U.T1 = 0.
      U.T2 = 0.
      U.HICDTUP = 0.
      U.CLIP3M = 0.
      U.CSI = 0.
      IF ( TYPE .NE. ' ' ) THEN
        IF ( AXIS .EQ. 'X' ) THEN
          U.XTYP = TYPE
        ELSE
          U.YTYP = TYPE
        END IF
      END IF
      IF ( UNITS .NE. ' ' ) THEN
        IF ( AXIS .EQ. 'X' ) THEN
          U.XUNITS = UNITS
        ELSE
          U.YUNITS = UNITS
        END IF
      END IF
      IF ( U.SCLFAC .NE. 0. ) THEN
        U.SCLFAC = REAL( U.SCLFAC * SFAC )
      ELSE
        U.SCLFAC = REAL( SFAC )
      END IF
      U.CD2 = AXIS//'-data scaled by '
      WRITE( U.CD2(20:), '(G15.6)', IOSTAT=IOS_W ) SFAC
      IF ( REPORT.OPEN ) WRITE( REPORT.UNIT, '(5X,A,G15.6)' )
     & AXIS//'-data scaled by ', SFAC

      ! Set default output file name
      OUT_FILE = FILE_NAME
      CALL FN_EXTRACT( OUT_FILE )
      IF ( .NOT. NO_FLAG ) CALL FN_FLAG( OUT_FILE, 's', 2, I )
      CALL ADD_PATH( DIR_OUT, OUT_FILE )
      IF ( .NOT. NO_INCR ) CALL FN_INCR( OUT_FILE )
      CALL FN_NAME_EXTRACT( OUT_FILE )
      DEF_FILE = OUT_FILE

      ! Set the output UDS file name
      IF ( .NOT. BATCH ) THEN
  120   WRITE( *, '(/A/3A/'' >> '',$)' )
     &   ' Output UDS file name?',
     &   ' [', DEF_FILE(:L_TRIM(DEF_FILE)), ']'
        READ( *, '(A)', END=190 ) OUT_FILE
        IF ( OUT_FILE .EQ. ' ' ) THEN ! Use default file name
          OUT_FILE = DEF_FILE
        ELSE ! Check file name validity
          CALL ADD_PATH( DIR_OUT, OUT_FILE )
          IF ( .NOT. FN_VALID( OUT_FILE ) ) THEN
            WRITE( *, * ) '*** Invalid file name'
            GO TO 120
          END IF
        END IF
      ELSE ! Batch
        OUT_FILE = DEF_FILE
      END IF

      ! Write the output UDS file
      CALL UDS_PUT( OUT_FILE, U, C, REPORT, OUTPUT_LIST,
     & DIR_OUT, .FALSE., IOS )

      ! Loop for next file
  190 WRITE( *, '(80(''_''))' )
      GO TO 100

      ! Clean up and stop
  199 CALL CLEAN_UP( HIT, REPORT, OUTPUT_LIST, DIR_OUT )

      END

      SUBROUTINE SCALE_CL( CL_ARG, NUM_ARGS, PROG_NAME,
     & AXIS_CL, SFAC_CL, TYPE_CL, UNITS_CL, NO_FLAG )

!***********************************************************************
!* Processes the Program-Specific Command Line Arguments
!***********************************************************************

      ! Headers
      INCLUDE 'uds_fxn.fi'

      ! Arguments ______________________________________________________

      CHARACTER*(*) CL_ARG(0:*) ! Command line argument array

      INTEGER NUM_ARGS ! Number of arguments

      CHARACTER*(*) PROG_NAME ! Program name

      CHARACTER AXIS_CL ! Axis to scale (X or Y)

      DOUBLE PRECISION SFAC_CL ! Scale factor

      CHARACTER*(*) TYPE_CL ! New data type

      CHARACTER*(*) UNITS_CL ! New data units

      LOGICAL NO_FLAG ! Indicates not to flag output file names

      ! Variables ______________________________________________________

      INTEGER I, NS, IOS

      CHARACTER ARG*255, C

      ! Process command line arguments
      AXIS_CL = ' '
      SFAC_CL = 0.D0
      TYPE_CL = ' '
      UNITS_CL = ' '
      NO_FLAG = .FALSE.
      DO I = 1, NUM_ARGS
        CALL STR_UPCASE( ARG, CL_ARG(I) )
        C = ARG(1:1)
        IF ( ( C .EQ. '-' ) .OR. ( C .EQ. '/' ) ) THEN
          NS = 2
        ELSE
          NS = 1
        END IF
        IF ( ( ARG(NS:) .EQ. '?' ) .OR.
     &   ( ARG(NS:) .EQ. '??' ) .OR.
     &   ( ARG(NS:) .EQ. 'HELP' ) ) THEN ! Show command line syntax
          CALL SYNTAX_CL( PROG_NAME )
          WRITE( *, '(10X,A)' )
     &     '[AXIS=<axis>] [FAC=<factor>] '//
     &     '[TYPE=<type>] [UNITS=<units>] [NO_FLAG]'
          IF ( ( ARG(NS:) .EQ. '??' ) .OR.
     &     ( ARG(NS:) .EQ. 'HELP' ) ) THEN ! Show command line help
            CALL HELP_CL( PROG_NAME )
            WRITE( *, '(4(10X,A/),10X,A)' )
     &       '<axis> :  Axis to scale (X or Y)',
     &       '<factor> :  Scale factor',
     &       '<type> :  '//
     &       'New data type for the scaled axis [no change]',
     &       '<units> :  '//
     &       'New units for the scaled axis [no change]',
     &       'NO_FLAG :  Don''t flag output file names'
          END IF
          STOP ' '
        ELSE IF ( ( ARG(NS:NS+4) .EQ. 'AXIS=' ) .OR.
     &   ( ARG(NS:NS+4) .EQ. 'AXIS#' ) ) THEN
          AXIS_CL = ARG(NS+5:NS+5)
          IF ( .NOT. ANY_CHARS( AXIS_CL, 'XY' ) ) THEN
            WRITE( *, '(/2A)' ) ' *** Illegal scale axis: ', AXIS_CL
            AXIS_CL = ' '
          END IF
          CL_ARG(I) = ' '
        ELSE IF ( ( ARG(NS:NS+3) .EQ. 'FAC=' ) .OR.
     &   ( ARG(NS:NS+3) .EQ. 'FAC#' ) ) THEN
          READ( ARG(NS+4:), '(BN,F25.0)', IOSTAT=IOS ) SFAC_CL
          IF ( IOS .NE. 0 ) THEN
            WRITE( *, '(/2A)', IOSTAT=IOS )
     &       ' *** Illegal scale factor: ',
     &       ARG(NS+4:L_TRIM(ARG))
            SFAC_CL = 0.D0
          END IF
          CL_ARG(I) = ' '
        ELSE IF ( ( ARG(NS:NS+4) .EQ. 'TYPE=' ) .OR.
     &   ( ARG(NS:NS+4) .EQ. 'TYPE#' ) ) THEN
          TYPE_CL = ARG(NS+5:)
          IF ( TYPE_CL .EQ. ' ' ) TYPE_CL = 'no_change'
          CL_ARG(I) = ' '
        ELSE IF ( ARG(NS:) .EQ. 'TYPE' ) THEN
          TYPE_CL = 'no_change'
          CL_ARG(I) = ' '
        ELSE IF ( ( ARG(NS:NS+5) .EQ. 'UNITS=' ) .OR.
     &   ( ARG(NS:NS+5) .EQ. 'UNITS#' ) ) THEN
          UNITS_CL = ARG(NS+6:)
          IF ( UNITS_CL .EQ. ' ' ) UNITS_CL = 'no_change'
          CL_ARG(I) = ' '
        ELSE IF ( ARG(NS:) .EQ. 'UNITS' ) THEN
          UNITS_CL = 'no_change'
          CL_ARG(I) = ' '
        ELSE IF ( ( ARG(NS:) .EQ. 'NO_FLAG' ) .OR.
     &   ( ARG(NS:) .EQ. 'NOFLAG' ) ) THEN
          NO_FLAG = .TRUE.
          CL_ARG(I) = ' '
        END IF
      END DO

      RETURN
      END

ext: for

max_stars_repo_name: DeadParrot/NHTSA-Tools

max_issues_repo_name: DeadParrot/NHTSA-Tools

max_forks_repo_name: DeadParrot/NHTSA-Tools


text:
        SUBROUTINE  LS_GEOP ( lsfrpt, isurf, ipt, iret )
C************************************************************************
C*                                                                      *
C* LS_GEOP                                                              *
C*                                                                      *
C* This subroutine decodes the group 4a(3)hhh, which contains the       *
C* geopotential height of an agreed standard isobaric surface.          *
C*                                                                      *
C* LS_GEOP  ( LSFRPT, ISURF, IPT, IRET )                                *
C*                                                                      *
C* Input parameters:                                                    *
C*      LSFRPT         CHAR*	         Report array                   *
C*      ISURF          CHAR*1	         WMO Table 0264 code figure     *
C*					                                *
C* Input and Output parameters:                                         *
C*      IPT            INTEGER           On input, points to 'a'; on    *
C*                                       output, points to the last h   *
C*                                       in the group 4ahhh             *
C*					                                *
C* Output parameters:                                                   *
C*      RIVALS(IRGHTM) REAL              Geopotential height            *
C*      RIVALS(IRPRLC) REAL              Standard isobaric surface for  *
C*                                       the geopotential               *
C*	IRET           INTEGER           Return code                    *
C*				   	 0 = normal return 	        *
C*                                                                      *
C**                                                                     *
C* Log:							                *
C* R. Hollern/NCEP      11/96                                           *
C* R. Hollern/NCEP       1/98   Changed interface, cleaned up code      *
C* A. Hardy/GSC          1/98	Reordered calling sequence              *
C************************************************************************
        INCLUDE          'GEMPRM.PRM'
        INCLUDE          'lscmn.cmn'
C*
        CHARACTER*(*)     lsfrpt
C*
        CHARACTER         fld3*3,   isurf*1
C------------------------------------------------------------------------
        iret = 0
        iflg = 0

        fld3 = lsfrpt ( ipt+1:ipt+3 )
        ipt = ipt + 3
        CALL  ST_INTG ( fld3, ival, ier )
C
        IF ( ier .ne. 0 ) RETURN
C
        rval = FLOAT ( ival )
C
        IF ( isurf .eq. '8' ) THEN
C
C*          Decoding the 850 mb surface.
C
            hgtm = rval + 1000.
            prlc = 850.
            iflg = 1
          ELSE IF ( isurf .eq. '7' ) THEN
C
C*          Decoding the 700 mb surface.
C
            IF ( rval .lt. 500 ) THEN
                hgtm = rval + 3000.
              ELSE
                hgtm = rval + 2000.
            END IF
            prlc = 700.
            iflg = 1
          ELSE IF ( isurf .eq. '1' ) THEN
C
C*          Decoding the 1000 mb surface.
C
            hgtm = rval
            prlc = 1000.
            iflg = 1
          ELSE IF ( isurf .eq. '2' ) THEN
C
C*          Decoding the 925 mb surface.
C
            hgtm = rval
            prlc = 925.
            iflg = 1
          ELSE IF ( isurf .eq. '5' ) THEN
C
C*          500 mb surface (cannot tell if height below 5000m).
C
        END IF
C
        IF ( iflg .eq. 1 ) THEN
            rivals ( irhgtm ) = hgtm
            rivals ( irprlc ) = prlc
        ENDIF
C*
        RETURN
        END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
program fixture
   use, intrinsic :: iso_fortran_env, only: wp => real64
   use json_module
   type(json_core) :: json
   type(json_value), pointer :: root
   complex*16 m6x6(6, 6), a(6, 6), b(6, 6)
   data((m6x6(i, j), i=1, 6), j=1, 6)/&
   &(1.2629542848807933, 0.9921603654457979),&
   &(-0.3262333607056494, -0.42951310949188126),&
   &(1.3297992629225006, 1.2383041008533804),&
   &(1.2724293214294047, -0.2793462818542693),&
   &(0.4146414344564082, 1.7579030898107073),&
   &(-1.5399500419037095, 0.5607460908880562),&
   &(-0.9285670347135381, -0.4527839725531578),&
   &(-0.2947204467905602, -0.8320432961178319),&
   &(-0.005767172747536955, -1.166570547084707),&
   &(2.404653388857951, -1.0655905803882961),&
   &(0.7635934611404596, -1.563782051071005),&
   &(-0.7990092489893682, 1.1565369971501793),&
   &(-1.1476570092363514, 0.8320471285723897),&
   &(-0.28946157368822334, -0.22732869142475534),&
   &(-0.29921511789731614, 0.2661373616721048),&
   &(-0.411510832795067, -0.3767027185836281),&
   &(0.2522234481561323, 2.4413646288945894),&
   &(-0.8919211272845686, -0.7953391172553718),&
   &(0.43568329935571865, -0.054877473711578625),&
   &(-1.237538421929958, 0.2501413228541527),&
   &(-0.22426788527830935, 0.6182432935662469),&
   &(0.37739564598170106, -0.17262350264585732),&
   &(0.1333363608148414, -2.2239002740099374),&
   &(0.8041895097449078, -1.263614384970583),&
   &(-0.057106774383808755, 0.3587288959713519),&
   &(0.5036079722337261, -0.011045478465663564),&
   &(1.085769362145687, -0.9406491626186084),&
   &(-0.6909538396968303, -0.11582532215695436),&
   &(-1.2845993538721883, -0.8149687088699175),&
   &(0.04672617218835198, 0.24226348085968588),&
   &(-0.23570655643950122, -1.4250983947324998),&
   &(-0.5428882550102544, 0.36594112304921983),&
   &(-0.4333103174567822, 0.2484126488725964),&
   &(-0.6494716467962331, 0.06528818167162072),&
   &(0.726750747385451, 0.01915639166027384),&
   &(1.1519117540872, 0.2573383771555333)/

   call json%initialize()
   call json%create_array(root, '')

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '0', 'l', 'u', 'n', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '1', 'l', 'u', 'n', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '2', 'l', 'l', 'n', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '3', 'l', 'l', 'n', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   a(2, 6) = (0._8, 0._8)
   call addcase(root, '4', 'r', 'u', 'n', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '5', 'r', 'u', 'n', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   a(2, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '6', 'r', 'l', 'n', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '7', 'r', 'l', 'n', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   a(1, 2) = (0, 0)
   call addcase(root, '8', 'r', 'u', 't', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   a(1, 2) = (0, 0)
   call addcase(root, '9', 'r', 'u', 'c', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '10', 'r', 'u', 'c', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '11', 'r', 'l', 't', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   a(6, 5) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '12', 'r', 'l', 't', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   a(6, 5) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '13', 'r', 'l', 'c', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   a(6, 5) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '14', 'r', 'l', 'c', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '15', 'r', 'l', 'c', 'u', 4, 6, (1._8, 0._8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '16', 'r', 'u', 'c', 'u', 4, 6, (1._8, 0._8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '17', 'l', 'u', 't', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '18', 'l', 'u', 'c', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '19', 'l', 'u', 'c', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '20', 'l', 'l', 'c', 'u', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '21', 'l', 'l', 't', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '22', 'l', 'l', 'c', 'n', 4, 6, (0.2_8, 0.8_8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '23', 'l', 'l', 'c', 'n', 4, 6, (0._8, 0._8), a, 6, b, 6)

   call copy(m6x6, a, 6, 6)
   call copy(m6x6, b, 6, 6)
   a(1, 1) = (0._8, 0._8)
   b(1, 1) = (0._8, 0._8)
   call addcase(root, '24', 'l', 'l', 'c', 'n', 4, 0, (0.2_8, 0.8_8), a, 6, b, 6)

   call print(root)
contains
   subroutine addcase(root, ncase, side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      type(json_core) :: json
      type(json_value), pointer :: root, case, array, data
      external ztrmm
      character side, uplo, transa, diag
      character(len=*) ncase
      integer n, m, lda, ldb
      complex*16 alpha, a(lda, n), b(ldb, n)
      call json%create_object(case, '')
      call json%add(root, case)
      call json%add(case, 'side', side)
      call json%add(case, 'uplo', uplo)
      call json%add(case, 'transa', transa)
      call json%add(case, 'diag', diag)
      call json%add(case, 'm', m)
      call json%add(case, 'n', n)
      call json%create_array(data, 'alpha')
      call json%add(data, '', dreal(alpha))
      call json%add(data, '', dimag(alpha))
      call json%add(case, data)
      nullify (data)
      call json%create_array(array, 'a')
      do j = 1, 6
         do i = 1, 6
            call json%create_array(data, '')
            call json%add(data, '', dreal(a(i, j)))
            call json%add(data, '', dimag(a(i, j)))
            call json%add(array, data)
            nullify (data)
         enddo
      enddo
      call json%add(case, array)
      nullify (array)
      call json%add(case, 'lda', lda)
      call json%create_array(array, 'b')
      do j = 1, 6
         do i = 1, 6
            call json%create_array(data, '')
            call json%add(data, '', dreal(b(i, j)))
            call json%add(data, '', dimag(b(i, j)))
            call json%add(array, data)
            nullify (data)
         enddo
      enddo
      call json%add(case, array)
      nullify (array)
      call json%add(case, 'ldb', ldb)
      call ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      call json%create_array(array, 'expect')
      do j = 1, 6
         do i = 1, 6
            call json%create_array(data, '')
            call json%add(data, '', dreal(b(i, j)))
            call json%add(data, '', dimag(b(i, j)))
            call json%add(array, data)
            nullify (data)
         enddo
      enddo
      call json%add(case, array)
      nullify (array)
      nullify (case)
   end subroutine addcase
   subroutine print(root)
      use, intrinsic :: iso_fortran_env, only: real64
      use json_module, CK => json_CK
      implicit none

      type(json_core) :: json
      type(json_value), pointer :: root
      logical :: status_ok
      character(kind=CK, len=:), allocatable :: error_msg
      call json%print(root, './tests/fixtures/level3/complex/trmm.json')
      if (json%failed()) then
         call json%check_for_errors(status_ok, error_msg)
         write (*, *) 'Error: '//error_msg
         call json%clear_exceptions()
         call json%destroy(root)
      end if
   end subroutine print
   subroutine copy(x, a, n, lda)
      integer n, lda
      complex*16 x(lda, n), a(lda, n)
      do j = 1, n
         do i = 1, lda
            a(i, j) = x(i, j)
         enddo
      enddo
   end subroutine copy
end

max_stars_repo_name: Schultzer/libblas

max_issues_repo_name: Schultzer/blas-rs

max_forks_repo_name: Schultzer/blas-rs


   !################################################################################!
 !/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\!
!######################################################################################!
!##!                                                                                !##!
!##!                                                                                !##!
MODULE Units_Module                                                                 !##!
!##!                                                                                !##!
!##!________________________________________________________________________________!##!
!##!                                                                                !##!
!##!    Contains the functions, and subroutines used to define and convert to and   !##!
!##!    from different unit systems to that which Poseidon uses.                    !##!
!##!                                                                                !##!
!##!================================================================================!##!
!##!                                                                                !##!
!##!    Contains:                                                                   !##!
!##!                                                                                !##!
!##!                                                                                !##!
!##!                                                                                !##!
!######################################################################################!
 !\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/!
   !################################################################################!

                            !*D*================================!
                            !                                   !
                            !           Dependencies            !
                            !                                   !
                            !===================================!
USE constants, &
            ONLY :  idp, pi

IMPLICIT NONE

                        !*F&S*==========================================!
                        !                                               !
                        !           Functions & Subroutines             !
                        !                                               !
                        !===============================================!

SUBROUTINE Set_Units( Units_Flag )

CHARACTER(LEN = 4)                          :: Units_Flag

IF ( Units_Flag == "C" ) THEN
!   CGS (centimeter-gram-second ) system
!
!   Mass    ->  g
!   Length  ->  cm
!   time    ->  s
!
!   c = 2.99792458e10 cm / s
!   G = 6.67428e-8    cm^3 / ( g s^2 )

    Meter = 100     ! centimeters

    Gram = 1        ! gram
    Kilogram = 1000 ! grams

    !Potential_Units = "cm/s^2"

    Grav_Constant_G = 6.67408*10**(-11) * (Meter*Meter*Meter)/(Kilogram * Second * Second)

    Speed_of_Light = 2.99792458*10**(8) * (Meter / Second )

ELSE IF ( Units_Flag == "S" ) THEN
    !   SI Units / MKS
    !
    !   Mass    ->  kg
    !   Length  ->  m
    !   time    ->  s
    !
    !   c = 2.99792458e8    m / s
    !   G = 6.67408e-11     m^2 / ( kg s^2 )

    Meter = 1       ! meter

    Gram = .001     ! kilograms
    Kilogram = 1    ! kilogram

    !Potential_Units = "m/s^2"

    Grav_Constant_G = 6.67408*10**(-11) * (Meter*Meter*Meter)/(Kilogram * Second * Second)

    Speed_of_Light = 2.99792458*10**(8) * (Meter / Second )

ELSE IF ( Units_Flag == "G" ) THEN
    !   Geometrized Units -> Poseidon Units
    !
    !   Mass    ->  g
    !   Length  ->  m
    !   time    ->  s
    !
    !   c = 1
    !   G = 1

    Meter = 1       ! meter

    Gram = 1        ! gram
    Kilogram = 1000 ! grams

    Grav_Constant_G = 1
    Speed_of_Light = 1

END IF

END SUBROUTINE Set_Units

END MODULE Units_Module