text:
Among the many things proposed to be bans banned in Davis, a ban on Plastic Bags was discussed in the late 2000s and early 2010s.

On November 12, 2013, the City Council adopted a SingleUse Carryout Bag Ordinance. The ordinance went into effect July 1, 2014.
http://recycling.cityofdavis.org/Media/Recycling/Documents/PDF/PW/Recycle/SingleUseBagsAmendment.pdf Ordinance #2422: SingleUse Carryout Bags Ordinance
On May 27, 2014 City Council voted to amend the Carryout Bag Ordinance to exempt restaurants from being required to charge 10 cents for paper or reusable bags.
http://recycling.cityofdavis.org/Media/Recycling/Documents/PDF/PW/Recycle/SingleUseCarryoutBagsOrdinance.pdf Ordinance #2436 SingleUse Carryout Bags Amendment

The banning of plastic bags is a very controversial subject. San Francisco has banned plastic bags for most supermarkets and pharmacies. San Jose, Alameda County, Los Angeles(the city), Unincorporated Los Angeles County, and unincorporated Santa Clara County have also banned plastic bags. As of March, 2012, 42 different public agencies in California have passed ordinances restricting the distribution of singleuse carryout bags.  On May 22, 2012, Hawaii became the first state in the country to ban plastic bags after all four counties in Hawaii decided to ban plastic bags (http://sierraclub.typepad.com/scrapbook/2012/05/hawaiiplasticbagban.html article).

There are many reasons for plastic bag bans. One major concern is that plastic bags litter cities and create a mess to clean up. Another concern is that animals can ingest plastic bags or suffocate due to plastic bags. Plastic bag litter cleanup is costly and the cost is ultimately passed onto taxpayers.

Supermarkets and other stores generally are neutral toward or supportive of plastic bag bans. Plastic bags are currently being given away for free by stores. If plastic bags are banned, stores can sell reusable bags and earn a profit this way. The stores also save money by not having to give away free plastic bags. Increased use of reusable bags also means that stores will no longer be losing as much money by giving out paper bags. Giving away plastic and paper bags for free increases prices for all customers.

The multibillion dollar plastic bag industry is vehemently opposed to plastic bag bans. Plastic bags are made mostly from foreign oil. Oil companies also stand to lose from a plastic bag ban. Big Oil is very powerful and will no doubt spend money to oppose any ban on plastic bags.

From experiences in San Francisco, San Jose, and Alameda County the impact to consumers will be minimal. Paper bags are still available. Reusable bags are readily available in supermarkets and pharmacies. Once people become used to carrying around reusable bags, a plastic bag ban is no big deal. Plastic bag bans can be good for the environment and ultimately will reduce costs for stores since they will no longer have to pay for plastic bags to give away for free. The cost savings from eliminating plastic bags will save stores money and ultimately can lead to lower prices.

The ultimate losers of a plastic bag ban are the plastic bag industry and oil companies.

City of Davis SingleUse Carryout Bag Ordinance

  The CarryOut Bag Ordinance applies to all retail, restaurants, and takeout food (fastfood) businesses.
  The ordinance does NOT apply to nonprofit charitable reuse stores (thrift stores).
Starting July 1, 2014:
  A business may NOT provide singleuse plastic carryout bags to customers (plastic carryout bags are banned).
  A business may provide customers with a recycled paper bag or reusable bag, but ONLY if the business charges a minimum price of 10 cents per bag.
  Restaurants are not required to charge a fee for paper or reusable bags provided for takeout food (Updated Notice: June 18th, 2014)
  Customers have the following options:
    Purchase a paper bag for a minimum of 10 cents (business may charge more than 10 cents if they wish)
   Purchase a reusable bag for a minimum of 10 cents (business may charge more than 10 cents if they wish)
   Bring their own reusable bags
   Refuse a bag and carry their merchandise out without a bag.
  A business may exempt customers paying for goods with WIC, CalFresh, SNAP or other food stamp cards from bag charges.
  Businesses retain the money collected from bag charges. The 10 cent paper bag passthrough is exempt from sales tax.
  Protective bags (without handles) may be provided at no charge for use to segregate and transport items to the cashier (e.g. bags for meat, produce, prescriptions, greeting cards, or bulk items).
  Paper bags must meet certain criteria. See the http://recycling.cityofdavis.org/businesses/singleusecarryoutbagordinance/resourcesforbusinesses/bagcompliance Bag Compliance page for details.
   Paper carryout bag must be 40 percent postconsumer recycled content minimum.
   An eight poundrated or smaller paper carryout bag must be 20 percent postconsumer recycled content minimum.
   The bags recycled content percentage must be printed on the paper carryout bag. (example: “Made from 40% postconsumer recycled materials”).
   The paper carryout bag must be recyclable and compostable (no plastic or cloth handles or other components).
  Reusable bags must meet certain criteria. See the http://recycling.cityofdavis.org/businesses/singleusecarryoutbagordinance/resourcesforbusinesses/bagcompliance Bag Compliance page for details. Reusable requirements:
   Must be machine washable or easily cleaned or disinfected.
   Does not contain lead, cadmium, or any other heavy metal in toxic amounts, as defined by applicable State and Federal standards and regulations for packaging or reusable bags.
   If made of plastic, is a minimum of at least 2.25 mils (thousandths of an inch) thick.
   Has a minimum lifetime of 125 uses, which for purposes of this subdivision, means the capability of carrying a minimum of 22 pounds 125 times over a distance of at least 175 feet.
 Enforcement is on a complaint basis.

More information about the http://recycling.cityofdavis.org/businesses/singleusecarryoutbagordinance SingleUse Carryout Bag Ordinance is found on DavisRecycling.org.

 Proposed DRAFT Davis Carryout Bag Ordinance
(NOTE: This is NOT the ordinance that the City ultimately voted to enact.  This section refers ONLY to the draft ordinance proposed by the Citys Natural Resources Commission)
At the request  of the Natural Resources Commission (NRC), and at the urging of the community, the City is looking into an ordinance limiting the distribution of singleuse carryout bags.  The goal of the ordinance is to reduce the distribution of single‐use carryout bags and encourage the switch to reusable carryout bags.

The http://publicworks.cityofdavis.org/Media/PublicWorks/Documents/PDF/PW/Recycle/CarryoutBagOrdinanceDraft.pdf original draft of the Citys Carryout Bag Ordinance would have only applied to grocery stores, convenience stores, liquor stores and large drug stores in Davisthis was changed by City Council and the final ordinance applies to ALL retail and ALL restaurants.  A 10 cent per bag charge would be applied to all carryout paper bags distributed at the point of sale at affected stores to encourage people to bring their own reusable bags. However, these paper bags must be recyclable and contain 40% postconsumer content as is the case with all similar municipal ordinances. The 10 cent charge is the estimated cost of recovery incurred by stores for distribution of the recyclable large sized paper bags and is also the most common fee imposed by other municipalities with such ordinances.  The stores keep the 10 cent fee. Reusable bags would be required to have a charge, to prevent retailers from simply handing out thicker plastic carry out bags for free.  The proposed ordinance would only restrict carryout bags provided at the point of sale, it does not include meat and produce bags or pharmacy bags.  Restaurants and food vendors would have been exempt under the proposed draft, but as noted above, City Council decided to include them in the final ordinance.

The DRAFT ordinance contained a mandate for retailers to track and report the use of paper bagsthis requirement was removed in the final ordinance that was passed by Council in November 2013. Some business owners considered this provision complicated and unnecessarily cumbersome. Others stated during public comment at meetings that they are required to itemize all things purchased by customers, bags included, so very little extra work would be required. Such clauses are not included in all similar ordinances, such as one recently passed in http://www.iwma.com/admin/ordinances/Draft%20Single%20Use%20Bag%20Ordinance%2011211.pdf San Luis Obispo County, which does not require reporting for paper bags. However, such a clause does allow the City of Davis to verify how effective the ordinance is in reducing singleuse carryout bags usage and verify if a store is noncompliant (handing out paper bags for free).  Ultimately, the City Council decided to remove the reporting requirements from the ordinance.

http://publicworks.cityofdavis.org/administrative/naturalresourcescommission/singleusecarryoutbags More information about the Citys DRAFT Carryout Bag Ordinance.
The NRC reviewed the draft ordinance at their http://publicworks.cityofdavis.org/Media/PublicWorks/Documents/PDF/PW/Recycle/0326NRCAgendaPacket.pdf#page16 March 26, 2012 meeting and voted 42 to accept the draft ordinance for staff to begin the CEQA environmental review process.
http://publicworks.cityofdavis.org/Media/PublicWorks/Documents/PDF/PW/Recycle/0227NRCAgendaPacket.pdf#page125 February 2012 Staff Report to the NRC regarding a proposed Carryout Bag Ordinance.

The ordinance was originally proposed by the Citys Natural Resources Commission NRC Zero Waste Subcommittee in November 2011. The NRC Subcommittee drafted an ordinance to cover all the major grocery, drug, and large chain stores in Davis (about 2 dozen total) while almost all of the small downtown business merchants would be exempt.  The Subcommittee estimated that this would eliminate well over 90% of the estimated 3,500,000 to 4,000,000 larger size, singleuse plastic bags distributed annually in Davis.  Restrictions on the thinner handleless plastic bags shoppers use for meats and produce within a store were not included in this ordinance for sanitary reasons and restaurants.

http://citycouncil.cityofdavis.org/Media/Default/Documents/PDF/CityCouncil/NaturalResourcesCommission/Agendas/Archive/Agenda20111128NaturalResourceCommission.pdf#page27 November 2011 Staff Report and NRC Proposed Carryout Bag Ordinance

 Other Local Efforts to Reduce SingleUse Carryout Bags in Davis

  CalPIRG has collected over 4,500 individually signed petitions to the NRC signed by UCD students requesting the City ban plastic bags.
  The Davis Food Coop has never bought and used singleuse takeout plastic bags, and already charges $0.05 for a paper bag.
  Trader Joes only gives out paper bags
  Several stores like Nugget and Target give you a discount for bringing your own bags
  The UC Davis Stores implemented a charge for single use bags after a bag ban proposal was brought forth by ASUCD Senator Darwin Moosavi

 Local impact of plastic bags after February 2012 high winds

February 2012 brought high winds to Davis and a pair of articles at the end of the month, describing the impact of plastic bags in Davis.

An article by Alan Pryor in The Vanguard (Wind Storm Litters Davis Countryside with Plastic Bags Right Before NRC Considers SingleUse Bag Ordinance) showed photos of thousands of plastic bags in the slough just to the south of the Yolo County Central Landfill.  Pryor stated, it was obvious they had been blown from the land fill over the retaining fence during the wind storm.  He also noted that the plastic bags had traveled quite a bit: Even worse, driving back to the freeway and West Sac along Co. Rd 105, I counted over 200 plastic bags in the weeds, trees, and barb wire fences along the roadways before even getting to the freeway. Some of these bags were over a mile away from the landfill.

The Davis Enterprise ran a similar article (Davis residents help clean up plastic bags near landfill), reporting on the experiences of Davisites Davis resident Cayce Wallace.  Confirming the Vanguard story, the article reported: The wind had blown plastic bags of all kinds off the landfill site and throughout the area, in some cases sending them more than two miles away to nearby farmland, and covering several spots where thousands of birds nested.  According to Wallace, There were a couple of great blue herons that were standing in the middle of the trash and egrets that were landing and then I went back and there were birds that had gotten caught up in the plastic. There was a kestrel and a cattle egret, they were picking at it, trying to get it off of them.  Wallace says that she helped untangle the birds from the bags and then spent several weeks trying to clean up the bags, accompanied by several friends.  According to Jacques DeBra, city of Davis public utilities manager, picking up all the garbage can be difficult, since new trash is brought in daily to the landfill, adding to the potential for noncompacted or uncovered trash to blow with the wind.  In 2010, the landfills staff estimated workers spent more than 1,815 hours picking up litter at the landfill, costing roughly $34,000.

Both articles are linked below.

 Media
The Davis Enterprise

  http://digital.davisenterprise.com/opinion/whyshoulddavisbansingleuseplasticbags/ Why should Davis ban singleuse plastic bags?
  http://digital.davisenterprise.com/news/localssaynixtheplasticcarrycloth2/ Locals say nix the plastic, carry cloth
  http://digital.davisenterprise.com/opinion/areplasticbagsreallyaproblem/ Are plastic bags really a problem?
  http://digital.davisenterprise.com/opinion/letters/bagbannersarevillagepests/ Bag banners are village pests
  http://www.davisenterprise.com/opinion/hereshowtoswitchtoreusablebags/ Heres how to switch to reusable bags
  http://www.davisenterprise.com/opinion/letters/ourtrashdoesendupinocean/ Our trash does end up in ocean
  http://www.davisenterprise.com/opinion/letters/addressproblematstatelevel/ Address problem at state level
  http://www.davisenterprise.com/opinion/letters/weoweittotheplanet/ We owe it to the planet
  http://www.davisenterprise.com/opinion/letters/checkoutplasticbagsexhibit/ Check out plastic bags exhibit
  http://www.davisenterprise.com/opinion/letters/moveforwardwithreusablebags/ Move forward with reusable bags
  http://www.davisenterprise.com/opinion/thepapergrocerybagendangered/ The paper grocery bag: endangered!
  http://www.davisenterprise.com/opinion/letters/plasticbagsputtogooduse/ Plastic bags put to good use
  http://www.davisenterprise.com/localnews/city/brownbaglunchtalktofocusonplasticbags/ Proposed plastic bag ban put on hold
  http://www.davisenterprise.com/opinion/letters/missingthebigpictureonbags/ Missing the big picture on bags
  http://www.davisenterprise.com/localnews/city/downtownmerchantsweighinonproposedbagban/ Downtown merchants weigh in on proposed bag ban, also including Conservation Coordinator Jennifer Gilbert.
  http://www.davisenterprise.com/localnews/city/davisresidentshelpcleanupplasticbagsnearyolocountycentrallandfill/ Davis residents help clean up plastic bags near landfill

  Bob Dunnings many thoughts on the topic:
   http://digital.davisenterprise.com/opinion/dunning/thisproposedbanistrulyinthebag/ This proposed ban is truly in the bag
   http://www.davisenterprise.com/opinion/dunning/abanmightmakeusfeelgoodbut/ A ban might make us feel good, but …
   http://www.davisenterprise.com/opinion/dunning/whywriteanordinancewhenyoucancraftanovel/ Why write an ‘ordinance’ when you can craft a novel?
   http://www.davisenterprise.com/opinion/dunning/aremyreusablebagsuptothetest/ Are my reusable bags up to the test?
   http://www.davisenterprise.com/opinion/dunning/canyoubalancemilkonyourpointyhead/ Can you balance milk on a pointy head?
   http://www.davisenterprise.com/opinion/dunning/doesdavisreallyneedthisintrusiveordinance/ Does Davis really need this intrusive ordinance?
   http://www.davisenterprise.com/opinion/dunning/letfreespeechbolsterourrightstobags/ Let free speech bolster our rights to bags
   http://www.davisenterprise.com/opinion/dunning/solutiontoourproblemsisinthebag/ Solution to our problems is in the bag
   http://www.davisenterprise.com/opinion/dunning/bagthefearmongeringandsticktothefacts/ Bag the fearmongering and stick to the facts

The Aggie
  http://theaggie.org/pdfs/20110518.pdf Students work toward reduction of singleuse plastic bags

The Peoples Vanguard of Davis
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id4154:morepubliceducationclearlyneededonplasticbagsissue&Itemid86 More Public Education Clearly Needed on Plastic Bags Issue
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id4866:nrctoconsiderrestrictionsonsingleuseplasticbags&catid53:landuseopenspace&Itemid86 NRC to Consider Restrictions on SingleUse Plastic Bags
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id5139:windstormlittersdaviscountrysidewithplasticbagsrightbeforenrcconsiderssingleusebagordinance&Itemid86 Wind Storm Litters Davis Countryside with Plastic Bags Right Before NRC Considers SingleUse Bag Ordinance

  This is just one of the many proposed bans in Davis

Comments.

20130612 03:09:27 nbsp Personally I love getting plastic bags. When I had an apartment Id always get plastic bags after buying groceries. I find them useful to put trash and recycle instead of using large trash bags. It saves me money. Also when Im at home in Davis I can use them to pick up poop for my dogs. Its a win/win situation in my book.  Users/teamdarwin
  Why do you think that other people should subsidize your use of plastic bags?  If you want plastic bags, buy them, and recognize that they have a real cost.  The world does not owe you free plastic bags.   Users/CovertProfessor

20130707 02:59:17 nbsp Yes the world owes me free plastic bags. Users/SarahMD

20130707 03:01:42 nbsp And healthcare. Users/SarahMD

20140125 15:50:59 nbsp I embrace the plastic bag for picking up the dog poo, too. Should this be on the dog page instead? BUT! Grocery Outlets plastic bags are so flimsy (as are CVS, safeway, I can go on), they cant even reliably hold dog poo, much less my groceries. But like the professor says, I do feel that I can afford to buy some bags for this personal item, except, OMG I have like thousands already stockpiled! Im set for dog poo Armageddon. PLEASE Davis, get this ban going.   Users/JaneBF

20140512 08:16:37 nbsp How is this handled in a grocery store?  Does the cashier wait until the bagger finishes bagging, then puts in the actual number of paper bags used for large orders?  (And lets recognize not all customers go through the express 15item or less lanes...I at least do large trips to save money)  Is there any recourse if the bagger uses more bags than we feel later were needed?  At a dime per bag, isnt in the stores interest to push unnecessary overusage of paper bags onto the customer?  Users/JeffWood Users/JeffWood
  Im going to guess that most stores will now bag everything first and then charge you, and if you object to the number of bags used, you are more than welcome to say so.  Stores arent going to make you buy a bag, they just cant give them out for free anymore.  JeffT

20140710 10:29:40 nbsp Some of these comments make no sense. A business has been giving customers plastic bags for years! The cost has been part of doing business. To claim that the bags have a real cost is pointlessthe cost has been part of the business for decades. If Target wanted to stop using bags, they were welcome to do so at any point. Any store can choose not to give the customers bags, or charge them for the bags. Its called doing business. What annoys me is the ban. If people want a business to save money or if they believe that the plastic bags are bad, they are welcome NOT to use the bags. But how about giving us the freedomthe optionto use the plastic bags for our purchases, perhaps then reuse the plastic bags for some other purpose (cleaning up after our dog, recycling cans, trash, etc.), and then recycle the plastic bags when we are done using them.
If the concern is trash, then how about a ban on all beverage holders? And perhaps a ban on cars as well? How about a ban on all packaging? A ban on all candy bar wrappers? I see more of that trash everywhere than plastic bags. Users/ChrisBenoit

20140710 10:36:48 nbsp Only rigid plastics are recyclable, like milk gallon containers. Users/ToddKaiser
What do the grocery stores do with the plastic bags in their recycle containers that say  plastic bags only ?  Sue
Hmmm not sure, Ive never even noticed those. But most small cities are not able to recycle plastic bags. It makes more sense to remove them from circulation rather than have 90% (making this figure up) end up in the dump. Todd

20140713 20:36:23 nbsp ChrisBenoit, actually I think a ban on unnecessary packaging is a great idea. Users/MeggoWaffle

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
SUBROUTINE OPENLOGF (xTOSCR, NAME, PROGNAM, VRSSTR, AUTHOR, TTNOTE)
  USE ttutilPrefs

  IMPLICIT NONE
! formal
  LOGICAL          :: xTOSCR, TTNOTE
  CHARACTER(LEN=*) :: NAME, PROGNAM, VRSSTR, AUTHOR

! local
  INTEGER               :: IULOG
  INTEGER, DIMENSION(6) :: DTARR
  DOUBLE PRECISION      :: DPDTTM
  CHARACTER(LEN=80)     :: FILNAM, DTSTR, MESSAG
  CHARACTER(LEN=132)    :: LINE
  REAL                  :: TTUVRS

! functions
  INTEGER :: GETUN

  if (MessagePrefsSet) call FatalERR ('OPENLOGF','cannot be called twice without resetting MESSINI')

! construct logfile name
  call EXTENS (NAME, 'LOG', 0, FILNAM)
  call UPPERC (FILNAM)

! get unit number and open file
  IULOG = GETUN(41,99)
  call FOPENS (IULOG,FILNAM,'new','del')

! current time
  call DTNOW (DTARR)
  call DTARDP (DTARR,0.0,DPDTTM)
  call DTDPST ('day-monthlt-year hour:min:sec',DPDTTM,DTSTR)

! logfile header
  write (IULOG,'(1X,5A)') 'This file ',TRIM(FILNAM),' was created at ',TRIM(DTSTR),' by'
  LINE = REPEAT('=',29+LEN_TRIM(FILNAM)+LEN_TRIM(DTSTR))
  write (IULOG,'(1X,A)') TRIM(LINE)

! initialize TTUTIL message system
  call MESSINI (xTOSCR,.TRUE.,IULOG)

! program / version / author
  call MESSWRT ('program',PROGNAM)
  call MESSWRT ('version',VRSSTR)
  call MESSWRT (' author',AUTHOR)

  if (TTNOTE) then
     call TTUVER (0.0, TTUVRS)
     write (MESSAG,'(A,F5.2)') 'linked with TTUTIL',TTUVRS
     call MESSWRT ('   note',MESSAG)
  end if

! end file and screen header
  write (IULOG,'(1X,A,/,A)') TRIM(LINE),' '
  if (xTOSCR) write (*,'(A)') ' '
Return
END SUBROUTINE OPENLOGF

max_issues_repo_name: zhumiansanren/FIRI-WHS


text:
      subroutine line_plane_t(xin,yin,zin,tin,alam,amue,anue,
     1     ibout_last,ibout,xout,yout,zout,tout,ttemp)
c s kelkar March 24, 06
c given the local coordinates of a point xin,yin,zin,t1 with respect to
c a node# ig in coarse grid, and the indices i,j,k that specify
c the subgrid cell that the point falls in, find the exit point
c xout,yout,zout along the line specified by alam, amue,anue
c********************************************************************
c INPUT VARIABLES
c
c OUTOUT VARIABLES
c
c INTERNAL VARIABLES
c********************************************************************
c tin=time at which the particle entered the subcell,
c     measured from the time at which it entered the coarse cell, ie
c     =0 when particle entered the coarse cell
c boundary_time(1:6) = time to boundary plane minus
c     the time of starting in the sub-cell
c ttemp = delta time to cross the cell (=tout-tin)
c tout = time particle exits the subcell, measured from the time
c     at which it entered the coarse cell
c INPUT
c     ig : node # of the node in the coarse grid
c     i,j,k : indices representing the cell in the subgrid
c     xin,yin,zin,tin : coordinates of the initial point
c     alam,amue,anue : equation of the straight line
c OUTOUT
c     xout,yout,zout,tout: coordinates of the exit point
c     ibout= index giving the exit plane, as follows:
c           1 : -x
c           2 : -y
c           3 : -z
c           4 : +x
c           5 : +y
c           6 : +z

      use comparttr_sg
      use comunits

      implicit none

      logical temp_flag

      integer ig,i,j,k,ind,ibout,ibout_last

      real*8 xin,yin,zin,alam,amue,anue,boundary_time(6)
      real*8 epsilon,xout,yout,zout,tout,ttemp,tin
      epsilon = 1.e-22

      do ind=1,6
         boundary_time(ind)=1.e+22
      enddo

c find the intersection of the line with the boundary planes
c in the direction of the particle movement
      if(alam.gt.epsilon) then
         boundary_time(4)=(boundary_cord(4)-xin)/alam
      elseif(alam.lt.-epsilon) then
         boundary_time(1)=(boundary_cord(1)-xin)/alam
      endif
      if(amue.gt.epsilon) then
         boundary_time(5)=(boundary_cord(5)-yin)/amue
      elseif(amue.lt.-epsilon) then
         boundary_time(2)=(boundary_cord(2)-yin)/amue
      endif
      if(anue.gt.epsilon) then
         boundary_time(6)=(boundary_cord(6)-zin)/anue
      elseif(anue.lt.-epsilon) then
         boundary_time(3)=(boundary_cord(3)-zin)/anue
      endif

c the face on which particle entered the subcell needs to be
c excluded as a possible outlet face. Do this by setting
c boundary_time(ibout_last) =-1 as a flag
      if(ibout_last.gt.0.and.ibout_last.le.6) then
         boundary_time(ibout_last) =-1.d00
      endif

c out of those planes to which travel time is +ve,
c find the boundary plane for which travel time is minimum.

      ttemp=1.e+22
      temp_flag=.true.
      do ind=1,6
c         if(boundary_time(ind).gt.epsilon) then
         if(boundary_time(ind).ge.0.) then
            if(boundary_time(ind).lt.ttemp) then
               ttemp=boundary_time(ind)
               ibout=ind
               temp_flag=.false.
            endif
         endif
      enddo

      if(temp_flag) then
         write(error_unit_number,*)
     1        'delta-t < epsilon in line_plane_t.STOP'
         write(error_unit_number,*)
     1        'xin,yin,zin,tin,alam,amue,anue='
         write(error_unit_number,*)
     1        xin,yin,zin,tin,alam,amue,anue
         stop
      endif

      xout=xin+alam*ttemp
      yout=yin+amue*ttemp
      zout=zin+anue*ttemp
      tout=ttemp+tin

      return

      end

c........................................................................

max_stars_repo_name: lanl/PLUMECALC

max_issues_repo_name: lanl/PLUMECALC

max_forks_repo_name: lanl/PLUMECALC


text:
Jaywalking is when a pedestrian Illegal in Davis illegally crosses a road. Generally, if youre in an area with a lot of traffic lights, chances are that jaywalking is illegal (CVC 21955). Downtown Davis has only a few of these:
  1st street after the underpass going towards campus

While it is not illegal to cross the road without a crosswalk except for the above exceptions, most drivers dont expect people to do so and you are legally obligated not to make yourself a hazard.

http://www.dmv.ca.gov/pubs/vctop/vc/tocd11c5.htm California Vehicle Code: Division 11 states that:
  Pedestrians must yield rightofway to vehicles except at marked or unmarked crosswalks. (CVC 21954)
  Between adjacent intersections controlled by traffic control signal devices or by police officers, pedestrians shall not cross the roadway at any place except in a crosswalk. (CVC 21955)
  Local laws can prohibit pedestrians from crossing roads at other than crosswalks. (CVC 21961)
(http://www.leginfo.ca.gov/cgibin/waisgate?WAISdocID6764105753+5+0+0&WAISactionretrieve full text of laws)

Davis Municipal Code/22 states that:
  Pedestrians must use crosswalks inside any school district. (22.10.020)
  Pedestrians must cross the road at a right angle or take the shortest path to the opposite curb except at a crosswalk. (22.10.030)

Places where jaywalking often occurs are:
  Covell Boulevard  Between Anderson Plaza and the adjacent apartments, and at Pole Line Road by the Oak Tree Plaza
  La Rue Road  Between The Colleges and the ARC.
  3rd Street  Between ACE Hardware and ACE Homeware

20051203 14:36:53 nbsp It seems like between ACE Hardware and ACE Homeware doesnt qualify as it isnt between controlled intersections? The Colleges are an example of a crossing between two controlled intersections. Users/JasonAller
   And yet The Colleges are not an example of a place in the City of Davis.

20051203 16:59:35 nbsp Are controlled intersections ruled by the same defenition as the ones in San Francisco are? I know there only streets with street lights boardering them are considered an example of such. Stop signs dont count. Users/JosephBleckman
  Your question should now be answered.

20051203 17:37:20 nbsp Just how often does the Davis police ticket people for jaywalking anyway? Users/AlexanderWoo

20060316 21:08:00 nbsp Yesterday (15 March 06) at about 3:30pm, I observed an incident of Jayriding at the intersection of Covell & Pole Line.  A burly and possibly intoxicated Hispanic individual rode his bike from the NE to SW corner as the traffic lights were changing.  A petite Asian lady in a westbound minivan (intending to turn right on Pole Line) was forced to come to an immediate stop when she spotted him leisurely cutting towards her.  The rider then performed some wheelies and bunny hops for his captive audience, as if his bike was a 63 Impala hopped up on pneumatics.  As these maneuvers got progressively outrageous, the rider eventually lost all control and spilled onto the pavement right in front of the minivan.  He lay in agony for only a few moments, but then nonchalantly stood up, picked up the bike, and walked off to the Oak Tree Plaza. Users/ErikAnderson

20080323 12:24:31 nbsp Have to admit, sometimes it seems safer to jaywalk Downtown when theres lots of traffic.  Having to watch for 2 cars going in 2 directions at the middle of a block is easier than having to watch for 4 cars going in 12 possible directions at an intersection, especially if drivers become confused over who goes next after a pedestrian has crossed during their turn. I make frequent use of the midblock crosswalks on E Street E, F Street F and G Street G streets on weekdays around noon or 5pm. Users/DukeMcAdow

 That is so true.  I work downtown so I tend to see a lot of bad (perhaps just confused) drivers that proceed before their proper turn simply because someone walked across the crosswalk.  Ive been hit once (a rather humorous incident involving me sprawled on the hood of the womans car after she decided she could just roll through a stop sign turning right while looking left for oncoming traffic) and nearly hit about 5 other times (everytime at an intersection and usually cause the driver wasnt expecting a pedestrian), but only ever at crosswalks, and only ever downtown.  I never thought of myself as accidentprone, but if its not bad driving, then maybe Im a bad pedestrian. Users/SunjeetBaadkar

      Just because you have the right of way, doesnt mean you can be ignorant for your own safety. Also, by law, pedestrians are obligated to pay attention and avoid accidents, both parties are responsible one way or another. Regarding downtown however, the most annoying thing about pedestrians is that when there is a lot of traffic and there are cars at every single stop sign both turning left, turning right, and going straight, the process actually gets complicated with many cars, and pedestrians only add into the mix. Anybody who drives into downtown regularly can attest to this. As for you people who say, Dont drive downtown, just bike or walk, there are roads downtown for a reason.


MODULE MODEL
    use READ_DATA
    IMPLICIT NONE
    INTEGER,DIMENSION(:),ALLOCATABLE:: visited_node
    CONTAINS
    FUNCTION  DISTANCE(i,j) !UPDATED
        INTEGER i,j
        INTEGER a,b
        REAL*8 distance,pi
        pi=dacos(-1d0)
        distance = 0d0
        IF(distance_definition.eq.1)THEN
                ! Arc distance with PBC
                 a=abs(j-i) ; b=n_spins-abs((j-i))
                 distance = dfloat(min(a,b))*distance_factor
        ELSE IF (distance_definition.eq.2)THEN
                ! Chord distance with PBC
                 distance =dfloat(n_spins)*sin(pi*dfloat(abs(i-j))/dfloat(n_spins))/pi
        END IF
    END FUNCTION
    SUBROUTINE COUPLING_MATRIX() !UPDATED
        IMPLICIT NONE
        INTEGER :: i,j,l,k,number_of_interactions,visit,n_iter
        REAL*8 ::probability_number,A_min,A_max,A_mid,Z_min,Z_max,Z_mid,norm_ct
        REAL :: random1,random2,pi,r1279
        LOGICAL :: repeated,accepted_j,connected
        pi=acos(-1.)
        ALLOCATE(visited_node(n_spins))
        n_iter=0
        connected=.FALSE.
        IF(is_initial_seed.eqv..TRUE.)THEN
                OPEN(41,FILE='interact_metrix.dat')
        END IF
        IF (matrix_definition.eq.1)THEN
                DO WHILE ((connected.eqv..FALSE.).and.(n_iter.lt.1000))
                n_iter=n_iter+1
                !+++++++++++++++++++++++++++++++++++++++++++++++
                !  NORMALIZATION CONSTANT
                !+++++++++++++++++++++++++++++++++++++++++++++++
                norm_ct=0d0
                DO j=2,n_spins
                        norm_ct=norm_ct+distance(1,j)**(-power_interactions)
                END DO

                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !  COUPLING MATRIX
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++

                number_neighbours=0
                eff_neigh=0
                spin_interaction=0.

                number_of_interactions=int(real(coordination_number*n_spins)/real(2))
                DO l=1,number_of_interactions
                        ! Choose random i
                        random1=r1279()
                        i=mod(int(real(n_spins)*random1),n_spins)+1
                        accepted_j=.FALSE.
                        DO WHILE (accepted_j.eqv..FALSE.)
                                !Choose random j
                                random2=r1279()
                                j=mod(int(real(n_spins)*random2),n_spins)+1
                                !Chech that is different form i and the
                                !interaction in not assigned
                                repeated=.FALSE.
                                DO k=1,number_neighbours(i)!If this interaction was assinged before, go to next pair
                                         IF(eff_neigh(i,k).eq.j)repeated=.TRUE.
                                END DO
                                IF(i.ne.j)THEN
                                        probability_number=(distance(i,j)**(-power_interactions))/norm_ct
                                END IF
                                random1=r1279()
                                IF((real(random1,8).lt.probability_number).and.(i.ne.j).and.(repeated.eqv..FALSE.))THEN
                                        !Valid interaction
                                        accepted_j=.TRUE.
                                        number_neighbours(i)=number_neighbours(i)+1
                                        number_neighbours(j)=number_neighbours(j)+1
                                        eff_neigh(i,number_neighbours(i))=j
                                        eff_neigh(j,number_neighbours(j))=i
                                        IF (interaction_definition.eq.1) THEN
                                                ! +-1 interaction
                                                ! distribution
                                                random1=r1279()
                                                IF (random1.lt.0.5) THEN
                                                        spin_interaction(i,number_neighbours(i))=1.
                                                        spin_interaction(j,number_neighbours(j))=1.
                                                ELSE
                                                        spin_interaction(i,number_neighbours(i))=-1.
                                                        spin_interaction(j,number_neighbours(j))=-1.
                                                END IF
                                        ELSE IF(interaction_definition.eq.2)THEN
                                                ! Gausian interaction distribution
                                                random1=r1279()
                                                random2=r1279()
                                                spin_interaction(i,number_neighbours(i))=sqrt(-2.*log(random1))*cos(2.*pi*random2)
                                                spin_interaction(j,number_neighbours(j))=spin_interaction(i,number_neighbours(i))
                                        ENDIF
                                        IF(is_initial_seed.eqv..TRUE.)THEN
                                                WRITE(41,*)i,j,spin_interaction(i,number_neighbours(i))
                                        END IF
                                END IF
                        END DO
                END DO
                visit=1
                visited_node=0
                CALL CHECK_CONNECTED_GRAPH(visit)
                !print*,'visited nodes',sum(visited_node)
                IF(sum(visited_node).eq.n_spins)THEN
                        connected=.TRUE.
                        print*,'connected graph found with',n_iter,'iterations'
                END IF
                END DO
                OPEN(40, FILE='seeds_used.dat', action='write',status='unknown',position='append')
                WRITE(40,*)read_seed,real(sum(number_neighbours))/real(n_spins),power_interactions,&
                &n_spins
                close(40)
        ELSE IF (matrix_definition.eq.2)THEN
                DO WHILE ((connected.eqv..FALSE.).and.(n_iter.lt.1000))
                n_iter=n_iter+1
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !   COMPUTING LOWER BOUND FOR A
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                probability_number=0d0
                DO j=2,n_spins
                        probability_number=probability_number+(1d0/(distance(1,j)**power_interactions))
                END DO
                A_min=dfloat(coordination_number)/probability_number
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !   COMPUTING Z
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                probability_number=0d0
                DO j=2,n_spins
                        probability_number=probability_number+(1d0-exp(-A_min/(distance(1,j)**power_interactions)))
                END DO
                Z_min=probability_number
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !   COMPUTING A FOR MAXIMUM Z
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                A_max=A_min
                DO i=1,500
                        probability_number=0d0
                        DO j=2,n_spins
                                probability_number=probability_number+(1d0-exp(-A_max/(distance(1,j)**power_interactions)))
                        END DO
                        IF (probability_number.gt.dfloat(coordination_number)) THEN
                                Z_max=probability_number
                                exit
                        END IF
                        A_max=A_max+1d-1*A_max
                END DO
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !   FINDING THE BEST A
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                DO i=1,500
                        A_mid=(A_max+A_min)/2d0

                        probability_number=0d0
                        DO j=2,n_spins
                                probability_number=probability_number+(1d0-exp(-A_mid/(distance(1,j)**power_interactions)))
                        END DO
                        Z_mid=probability_number

                        IF (Z_mid.gt.dfloat(coordination_number))THEN
                                A_max=A_mid
                                Z_max=Z_mid

                        ELSE IF (Z_mid.lt.dfloat(coordination_number))THEN
                                A_min=A_mid
                                Z_min=Z_mid
                        END IF
                        IF(abs(Z_max-Z_min).le.1d-5)THEN
                                exit
                        END IF
                END DO
                probability_number=0d0
                DO j=2,n_spins
                        probability_number=probability_number+(1d0-exp(-A_mid/(distance(1,j)**power_interactions)))
                END DO

                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !  COUPLING MATRIX
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                number_neighbours=0
                eff_neigh=0
                spin_interaction=0.

                DO i=1,n_spins
                        DO j=i+1,n_spins
                                repeated=.FALSE.
                                DO k=1,number_neighbours(i)!If this interaction was assinged before, go to next pair
                                        IF(eff_neigh(i,k).eq.j) repeated=.TRUE.
                                END DO
                                IF(i.ne.j)THEN
                                        probability_number=1d0-exp(-A_mid/(distance(i,j)**power_interactions))
                                END IF
                                random1=r1279()
                                IF((real(random1,8).lt.probability_number).and.(i.ne.j).and.(repeated.eqv..FALSE.))THEN
                                        !Valid interaction
                                        number_neighbours(i)=number_neighbours(i)+1
                                        number_neighbours(j)=number_neighbours(j)+1
                                        eff_neigh(i,number_neighbours(i))=j
                                        eff_neigh(j,number_neighbours(j))=i
                                        IF (interaction_definition.eq.1) THEN
                                                ! +-1 interaction
                                                ! distribution
                                                random1=r1279()
                                                IF (random1.lt.0.5) THEN
                                                        spin_interaction(i,number_neighbours(i))=1.
                                                        spin_interaction(j,number_neighbours(j))=1.
                                                ELSE
                                                        spin_interaction(i,number_neighbours(i))=-1.
                                                        spin_interaction(j,number_neighbours(j))=-1.
                                                END IF
                                        ELSE IF(interaction_definition.eq.2)THEN
                                                ! Gausian interaction
                                                ! distribution
                                                random1=r1279()
                                                random2=r1279()
                                                spin_interaction(i,number_neighbours(i))=sqrt(-2.*log(random1))*cos(2.*pi*random2)
                                                spin_interaction(j,number_neighbours(j))=spin_interaction(i,number_neighbours(i))

                                        ENDIF
                                        IF(is_initial_seed.eqv..TRUE.)THEN
                                                WRITE(41,*)i,j,spin_interaction(i,number_neighbours(i))
                                        END IF
                                END IF
                        END DO
                END DO
                visit=1
                visited_node=0
                CALL CHECK_CONNECTED_GRAPH(visit)
                !stop
                !print*,'visited nodes',sum(visited_node)
                IF(sum(visited_node).eq.n_spins)THEN
                        connected=.TRUE.
                        print*,'connected graph with',n_iter,'iterations'
                END IF
                END DO
                OPEN(40, FILE='seeds_used.dat', action='write',status='unknown',position='append')
                WRITE(40,*)read_seed,A_mid,real(sum(number_neighbours))/real(n_spins),power_interactions,&
                &n_spins
                close(40)
        ENDIF
        IF(is_initial_seed.eqv..TRUE.)THEN
                WRITE(41,*)'#####################'
                close(41)
        END IF
    END SUBROUTINE
    RECURSIVE SUBROUTINE CHECK_CONNECTED_GRAPH(to_visit)
        IMPLICIT NONE
        INTEGER :: to_visit,i,next_visit
        visited_node(to_visit)=1
        DO i=1,number_neighbours(to_visit)
                !print*,to_visit,eff_neigh(to_visit,i),visited_node(eff_neigh(to_visit,i))
                IF (visited_node(eff_neigh(to_visit,i)).eq.0)then
                        next_visit=eff_neigh(to_visit,i)
                        CALL CHECK_CONNECTED_GRAPH(next_visit)
                END IF
        END DO
     END SUBROUTINE
END MODULE MODEL


text:
	SUBROUTINE GSCNTR  ( ibxsub, ilblbk, ismoth, isadjf, iret )
C************************************************************************
C* GSCNTR								*
C* 									*
C* This subroutine sets the contour attributes which include the grid	*
C* box subset factor, the label color for the background behind labels,	*
C* the number of smoothing passes for lines, and the spline adjustment	*
C* factor.								*
C*									*
C* GSCNTR  ( IBXSUB, ILBLBK, ISMOTH, ISADJF, IRET )			*
C*									*
C* Input parameters:							*
C*									*
C*	IBXSUB		INTEGER		Grid box subset factor		*
C*	ILBLBK		INTEGER		Label background color		*
C*	ISMOTH		INTEGER		Number of smoothing passes	*
C*	ISADJF		INTEGER		Spline adjustment factor	*
C*									*
C* Output parameters:							*
C*									*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/NMC	11/91	GEMPAK 5.1				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERROR.PRM'
	INCLUDE		'CONTUR.CMN'
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Check that parameters are valid.
C
	IF  ( ibxsub .ge. 0 )  THEN
	    jbxsub = ibxsub
	END IF
	IF  ( ilblbk .ge. 0 )  THEN
	    jlblbk = ilblbk
	END IF
	IF  ( ismoth .ge. 0 )  THEN
	    jsmoth = ismoth
	END IF
	IF  ( ( isadjf .ge. 0 ) .and. ( isadjf .le. 100 ) )  THEN
	    jsadjf = isadjf
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


! { dg-do compile }
!
! PR fortran/50050
! Out of bound whilst releasing initialization of allocate object
!
! Contributed by someone <sigurdkn@gmail.com>

program bug
  implicit none
  type foo
    integer, pointer :: a => null()
  end type
  type(foo), dimension(:,:), allocatable :: data
  allocate(data(1:1,1)) ! This used to lead to an ICE
end program


text:
	SUBROUTINE SF_TNXT  ( isffln, dattim, iret )
C************************************************************************
C* SF_TNXT								*
C*									*
C* This subroutine selects the next time in a surface file.  SF_TSTN	*
C* must be called to set the station before this subroutine is called.	*
C* The times will be returned in the order in which they appear in	*
C* the file, rather than in chronological order.  Data for this time	*
C* can be read or written by calling SF_RDAT or SF_WDAT, respectively.	*
C*									*
C* SF_TNXT  ( ISFFLN, DATTIM, IRET )					*
C*									*
C* Input parameters:							*
C*	ISFFLN		INTEGER	 	Surface file number		*
C*									*
C* Output parameters:							*
C*	DATTIM		CHAR*		GEMPAK date/time		*
C*	IRET		INTEGER		Return code			*
C*				    	   0 = normal return		*
C*				   	  -3 = file not open		*
C*				   	  -9 = no more times		*
C*				  	 -18 = station not set		*
C**									*
C* Log:									*
C* I. Graffman/RDS	5/87						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GMBDTA.CMN'
	INCLUDE		'sfcmn.cmn'
C*
	CHARACTER*(*)	dattim
C*
	INTEGER		iheadr (MMKEY)
C------------------------------------------------------------------------
	CALL SF_CHKF  ( isffln, iret )
	IF  ( iret .ne. 0 )  RETURN
	IF  ( .not. stnset (isffln) )  THEN
	    iret = -18
	    RETURN
	END IF
C
C*	Obtain next row/column.
C
	CALL DM_NEXT  ( isffln, irow, icol, ier )
	IF  ( ier .ne. 0 )  THEN
	    iret =  -9
	    curtim (isffln) = ' '
	    RETURN
	END IF
C
C*	Determine data location (row or col) and read from file.
C
	IF  ( dttype (isffln) .eq. 'ROW' )  THEN
	    CALL DM_RRWH  ( isffln, irow, iheadr, ier1 )
	  ELSE
	    CALL DM_RCLH  ( isffln, icol, iheadr, ier1 )
	END IF
C
C*	Retrieve output values from headers.
C
     	CALL TI_CDTM  ( iheadr ( kdate (isffln) ),
     +			iheadr ( ktime (isffln) ), dattim, ier )
C
C*	Save the row and column.
C
	krow (isffln)   = irow
	kcol (isffln)   = icol
	curtim (isffln) = dattim
C*
	RETURN
	END


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

C   --*** DBPNAM *** (EXOLIB) Print database variable names
C   --   Written by Amy Gilkey - revised 01/21/88
C   --
C   --DBPNAM displays the database variable names.
C   --
C   --Parameters:
C   --   OPTION - IN - '*' to print all, else print options:
C   --                 'G' to print global variable names
C   --                 'N' to print nodal variable names
C   --                 'E' to print element variable names
C   --   NVARGL - IN - the number of global variables (if OPTION)
C   --   NVARNP - IN - the number of nodal variables (if OPTION)
C   --   NVAREL - IN - the number of element variables (if OPTION)
C   --   NAMEGV - IN - the global variable names (if OPTION)
C   --   NAMENV - IN - the nodal variable names (if OPTION)
C   --   NAMEEV - IN - the element variable names (if OPTION)

      include 'ag_namlen.blk'

      CHARACTER*(*) OPTION
      INTEGER NVARGL, NVARNP, NVAREL
      CHARACTER*(NAMLEN) NAMEGV(*)
      CHARACTER*(NAMLEN) NAMENV(*)
      CHARACTER*(NAMLEN) NAMEEV(*)
      LOGICAL ALL

      ALL = (OPTION .EQ. '*')

      WRITE (*, 10000)

      IF (ALL .OR. (INDEX (OPTION, 'G') .GT. 0)) THEN
         WRITE (*, 10010) 'Global: ', (NAMEGV(I), I=1,NVARGL)
      END IF
      IF (ALL .OR. (INDEX (OPTION, 'N') .GT. 0)) THEN
         WRITE (*, 10010) 'Nodal:  ', (NAMENV(I), I=1,NVARNP)
      END IF
      IF (ALL .OR. (INDEX (OPTION, 'E') .GT. 0)) THEN
         WRITE (*, 10010) 'Element:', (NAMEEV(I), I=1,NVAREL)
      END IF

      RETURN

10000  FORMAT (/, 1X, 'Variables Names:')

10010  FORMAT (4X, A, :, 2 (2X, A), :, /,
     &        (12X, 2 (2X, A)))
      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
c__________________________________________________________
c
        subroutine bdrcsu(nd,nbdmx,ndp,idp,nds,ids,ioff,
     &       dt,time_int)

        include 'iounits.inc'

c       idp - array of record ranges to not process
c       ids - array of record ranges to not stack
c       ndp - array giving number of record ranges for each level
c       nds -   "     "      "            (for ids)
c       there is a seperate set of ranges for each level; level
c       zero corresponds to all levels  --   i.e. records specified in
c       level zero of idp ( ids) are not proceesed ( stacked)
c       at any level

c       now also gets record offset (i.e. the number which should be
c       added to the record numbers in the c. file to make them
c       correct (i.e. agree wtih other stations)); note: the offset
c       is added to the bad record intervals idp and ids; these should thus
c       be specified with the (erroneous) records which are on the plot

c       info is read from file brsta000x
      integer ndp(0:nd),nds(0:nd),idp(0:nd,2,nbdmx),ids(0:nd,2,nbdmx)
      integer*8 time_int
cnew      character*80 cfbr

      parameter (nbmx = 200,ndmx=8)
c       need to change parameters in other subroutine in file !!!
      integer iflag(nbmx)
      integer nbr(2,0:ndmx),ibr(2,0:ndmx,2,nbmx) !,imap(2,4)
      real irecb(2,nbmx),dtBadRec,dt,multFac
      character*80 cstring

      open(unit = br_unit, file = cfbr,status='old',err=200)

c     new verision : also tries to read in sampling rate used
c     to define bad record times relative to clock zero; this
c     is required because plotting program might use decimated
c     data files for greater efficiency
c     ALSO: bad record usage was never adapted to work with
c      the new approach to computing set numbers: record numbers
c      are relative to start of file; set offsets are computed
c      from time_int (number of seconds between "clock zero" and
c      start of data)
      read(br_unit,'(a)') cstring
      read(cstring,*,err=5) nseg, dtBadRec
      multFac = dtBadRec/dt
      go to 10
5     multFac = 1
      read(cstring,*) nseg
10    continue
      do i = 1,nseg
         read(br_unit,*) irecb(1,i),irecb(2,i),iflag(i)
         irecb(1,i) = int(multfac*(irecb(1,i)-time_int/dtbadRec))
         irecb(2,i) = int(multfac*(irecb(2,i)-time_int/dtBadRec))
      enddo

      call mkbr(nseg,irecb,iflag,nd,nbr,ibr)

      read(br_unit,*,end = 112) ioff
      go to 115
112   print*,'no offset in br file; assuming zero offset'
      ioff = 0
115   continue
      close(br_unit)

c       add offset to bad record intervals
      do 125 id = 0,nd
         ndp(id) = nbr(1,id)
         do 120 j = 1,ndp(id)
            idp(id,1,j) = ibr(1,id,1,j) + ioff
            idp(id,2,j) = ibr(1,id,2,j) + ioff
120         continue
         nds(id) = nbr(2,id)
         do 122 j = 1,nds(id)
            ids(id,1,j) = ibr(2,id,1,j) + ioff
            ids(id,2,j) = ibr(2,id,2,j) + ioff
122         continue
125      continue
      return

c       this block is for no bad data (i.e., no bad record file found)
200   continue
      do 210 id = 0,nd
         ndp(id) = 0
210      continue
      do 310 id = 0,nd
         nds(id)= 0
310      continue
      ioff = 0
      close(69,status = 'delete')
      print*,'No bad record file found for this file;  ',
     &'Using all data '
      return
      end
c______________________________________________________________________
c
      subroutine mkbr(nseg,irecb,iflag,nd,nbr,ibr)
      parameter (nbmx=200,ndmx=8)
      integer iflag(nseg)
      integer nbr(2,0:ndmx),ibr(2,0:ndmx,2,nseg),imap(2,4)
      real irecb(2,nseg)
      data imap/1,0, 2,0, 2,4, 1,0/
c      imap(1,.) = 1 to not process, 2 to flag as bad
c      imap(2,.) = 0 for all levels, else = level to omit (only allows one
c             level or all for now)
c      imap(1,.) is for magnetics bad
c      imap(2,.) is for electrics bad
c      imap(3,.) is for long period bad
c      imap(4,.) is for all bad
c      My choices of imap for these four "buttons" are given in data statment
c        for imap

      do 5 i=0,nd
      do 5 k = 1,2
         nbr(k,i) = 0
5        continue

      do 100 j = 1,nseg
         nbr(imap(1,iflag(j)),imap(2,iflag(j))) =
     &       nbr(imap(1,iflag(j)),imap(2,iflag(j))) + 1
         do 50 k = 1,2
            ibr(imap(1,iflag(j)),imap(2,iflag(j)),k,
     &             nbr(imap(1,iflag(j)),imap(2,iflag(j)))) = irecb(k,j)
50           continue
100      continue

      return
      end

max_stars_repo_name: simpeg-research/iris-mt-scratch

max_issues_repo_name: simpeg-research/iris-mt-scratch

max_forks_repo_name: simpeg-research/iris-mt-scratch


text:
subroutine sld_output(a,itask)
    !-----------------------------------------------------------------------
    !****f* SOLIDS/sld_output
    ! NAME
    !    sld_output
    ! DESCRIPTION
    !    End of a SOLIDS time step
    !    itask = 0  When timemarching is true. There is output or post-process
    !               of results if required.
    !    itask = 1  When timemarching is false. Output and/or post-process of
    !               results is forced if they have not been written previously.
    ! USES
    !    output
    !    a%FilePostpr%postpr
    ! USED BY
    !    sld_endste (itask=0)
    !    sld_turnof (itask=1)
    !***
    !-----------------------------------------------------------------------
    use typre
    use Mod_Postpr
    use Mod_Solids
    implicit none
    class(SolidsProblem) :: a
    integer(ip)                :: itask
    integer(ip), save       :: dopost(49)
    integer(ip)             :: itime,istat,ifiel,ndime,aux4
    real(rp)                :: dummr

    select case(itask)

    !End of a time step.
   case(0)
      a%pos_alrea=0
     !-------------------------------------------------------------------------
     ! Postprocess at a given time

      !Tracking of points.
      if(a%nptra > 0) then
         call a%PointTracking
      end if

   case(1)

   end select

   !Decide which postprocesses need to be done
   call SetupDoPost(itask,a%istep,size(a%npp_stepi),a%npp_inits,a%npp_stepi,a%pos_alrea,dopost)

   !Do the actual postprocess
   !Displacements
   if (dopost(1) == 1) then
      call a%FilePostpr%postpr(a%disp(:,:,1),'Disp',a%istep,a%ctime,a%Mesh)
   end if

   !Stress tensor
   if (dopost(2) == 1) then
       if(a%kfl_printStress .eqv. .true.) then
           call a%FilePostpr%postgp(a%stress_g,'Gauss Stress',a%istep,a%ctime,a%Mesh,'voigtT')
       end if
   end if

  !Strain
  if (dopost(21) == 1) then
      if(a%kfl_NodalStress.eqv. .true.) then
          if(a%kfl_printStress.eqv. .true.) then
              call a%FilePostpr%postpr(a%stress(:,:),'Nodal Stress',a%istep,a%ctime,a%Mesh,'voigtT')
          endif
      endif
  endif

   !Strain tensor
   if (dopost(3) == 1) then
       if(a%kfl_printStrain .eqv. .true.) then
           call a%FilePostpr%postgp(a%strain_g,'Gauss Strain',a%istep,a%ctime,a%Mesh,'voigtT')
       end if
   end if

  !Strain
  if (dopost(22) == 1) then
      if(a%kfl_NodalStrain .eqv. .true.) then
          if(a%kfl_printStrain.eqv. .true.) then
              call a%FilePostpr%postpr(a%strain(:,:),'Nodal Strain',a%istep,a%ctime,a%Mesh,'voigtT')
          endif
      endif
  endif

   !Internal tractions
   if (dopost(4) == 1) then
      call a%FilePostpr%postpr(a%btraction_nodal,'Sld_traction',a%istep,a%ctime,a%Mesh)
   end if

   !Fluid traction - nodal
   if (dopost(5) == 1) then
         if(associated(a%trac)) then
             call a%FilePostpr%postpr(-a%trac,'Fld_traction',a%istep,a%ctime,a%Mesh)
         end if
   endif

   !Total external traction - Gaussian
   if (dopost(6) == 1) then
       call a%FilePostpr%postgp(a%btraction,'Btraction',a%istep,a%ctime,a%Mesh)
   end if

   !Velocity
   if (dopost(7) == 1) then
       if(a%kfl_timei==1) then
           call a%FilePostpr%postpr(a%veloc(:,:,1),'Velocity',a%istep,a%ctime,a%Mesh)
       end if
   end if

   !Principal Strain tensor - generally auto used by sldALE to deform mesh
   if (dopost(8) == 1) then
       if(a%kfl_printPrincipalStresses) then
           call a%FilePostpr%postgp(a%printPStrain,'PpalStrain',a%istep,a%ctime,a%Mesh,'voigtT')
       end if
   endif

   !Acceleration
   if (dopost(9) == 1) then
       if(a%kfl_timei==1) then
           call a%FilePostpr%postpr(a%accel(:,:,1),'Acceleration',a%istep,a%ctime,a%Mesh)
       end if
   end if

   !Sigma
   if (dopost(11) == 1) then
       call a%FilePostpr%postpr(a%sigma(:,:,1),'Sigma',a%istep,a%ctime,a%Mesh,'voigtT')
   endif

   !Pressure
   if (dopost(12) == 1) then
       call a%FilePostpr%postpr(a%press(:,1),'Press',a%istep,a%ctime,a%Mesh)
   end if

   !Stress tensor
   if (dopost(20) == 1) then
        if(a%kfl_printGaussSigma) then
           call a%FilePostpr%postgp(a%sigma_g,'Gauss Sigma',a%istep,a%ctime,a%Mesh,'voigtT')
       endif
   end if

   if (dopost(23) == 1) then
        if(a%kfl_printGaussPress) then
           call a%FilePostpr%postgp(a%press_g,'Gauss Press',a%istep,a%ctime,a%Mesh)
       endif
   end if

   call a%SolidSpecificOutput(itask)

end subroutine sld_output

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
*----------------------------------------------------------------------*
      FUNCTION SETARANDOM()
*----------------------------------------------------------------------*
      REAL*8 SETARANDOM
      CHARACTER date*8,time*10,rtime*10
      INTEGER i
*----------------------------------------------------------------------*

      CALL DATE_AND_TIME(date,time)
      DO i=1,10
        rtime(i:i) = time(11-i:11-i)
      ENDDO
      READ(rtime,*) SETARANDOM
      SETARANDOM=SETARANDOM/1000.0

      RETURN
      END

      FUNCTION check_ft_grow(tmp,bbm,bb0,bbf,bbl,xchill,xdschill)
      IMPLICIT NONE
      REAL*8 tmp(12,31),bb0,bbf,bbl,bbsum
      INTEGER bbm,jday,day,mnth,jd,check_ft_grow,xchill,xdschill
      INTEGER chill,dschill,i

      chill = xchill
      dschill = xdschill

*----------------------------------------------------------------------*
* Check for budburst using degree days.                                *
*----------------------------------------------------------------------*
      IF (bbm.GT.0) THEN
      jday = 0
10    jday = jday + 1

*----------------------------------------------------------------------*
* Check for chilling.                                                  *
*----------------------------------------------------------------------*
        IF (chill.EQ.0) THEN
          bbsum = 0.0d0
          DO i=1,20
            mnth = (jday+i-1)/30 + 1
            day = jday + i - (mnth - 1)*30
            mnth = mod(mnth-1,12) + 1
            IF (tmp(mnth,day).LT.-5.0d0)  bbsum = bbsum +
     &max(-10.0d0,tmp(mnth,day)+5.0d0)
          ENDDO
          IF (bbsum.LT.-100) THEN
            chill = 1
            dschill = 1
          ENDIF
        ENDIF
        IF (chill.EQ.1) THEN
          dschill = dschill + 1
        ENDIF
        IF (dschill.GT.260) THEN
          chill = 0
          dschill = 0
        ENDIF

*        print*,'in func ',mnth,day,chill,dschill

        bbsum = 0.0d0
        DO i=1,bbm
          mnth = (jday+i-1)/30 + 1
          day = jday + i - (mnth - 1)*30
          mnth = mod(mnth-1,12) + 1
          IF (tmp(mnth,day).GT.bb0)  bbsum = bbsum +
     &min(bbf,tmp(mnth,day)-bb0)
        ENDDO
*        print*,bbsum,exp(0.01d0*real(dschill))
        IF (real(bbsum).GE.real(bbl)*exp(-0.01d0*real(dschill))) THEN
          check_ft_grow = 1
          GOTO 20
        ENDIF
        IF ((jday.GE.360+bbm)) THEN
          check_ft_grow = 0
          GOTO 20
        ENDIF
      GOTO 10
20    CONTINUE
      ELSE
        check_ft_grow = 1
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
      FUNCTION minx(x)
*----------------------------------------------------------------------*
      real*8 x(12),minxx
      integer minx,i

      minx = -10
      minxx = 100000000.0d0
      DO i=1,12
        IF (x(i).LT.minxx) then
          minxx = x(i)
          minx = i
        ENDIF
      ENDDO

      RETURN
      END

*----------------------------------------------------------------------*
      FUNCTION dfn(age,mature)
*----------------------------------------------------------------------*
      INTEGER age,lsd
      PARAMETER(lsd = 200)
      REAL*8 mature,dfn

      IF (age.GT.mature) THEN
        dfn = 1.0d0 - 0.5d0*(real(age) - mature)/(real(lsd) -
     &mature)
      ELSE
        dfn = (real(age)/mature)**2.0d0
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION ttg                                *
*                          ************                                *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION ttg(i,ttglim)
*----------------------------------------------------------------------*
      INTEGER i,ttglim
      REAL*8 ttg

      ttg = real(ttglim + 1 - i)/real(ttglim)
      IF (ttg.LT.0.0d0)  ttg = 0.0d0

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION triscale2                          *
*                          ******************                          *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION triscale2(x,y,x1,x2,x3,y1,y2,y3)
*----------------------------------------------------------------------*
      REAL*8 triscale2,x,y,x1,x2,x3,y1,y2,y3,s1,s2

      IF ((x.LT.x1).OR.(x.GT.x3).OR.(y.LT.y1).OR.(y.GT.y3)) THEN
        triscale2 = 0.0d0
      ELSE
        IF (x.LT.x2) THEN
          s1 = (x - x1)/(x2 - x1)
        ELSE
          s1 = (x - x3)/(x2 - x3)
        ENDIF
        IF (y.LT.y2) THEN
          s2 = (y - y1)/(y2 - y1)
        ELSE
          s2 = (y - y3)/(y2 - y3)
        ENDIF
        triscale2 = s1*s2
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION triscale                           *
*                          *****************                           *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION triscale(x,x1,x2,x3)
*----------------------------------------------------------------------*
      REAL*8 triscale,x,x1,x2,x3

      IF ((x.LT.x1).OR.(x.GT.x3)) THEN
        triscale = 0.0d0
      ELSE
        IF (x.LT.x2) THEN
          triscale = (x - x1)/(x2 - x1)
        ELSE
          triscale = (x - x3)/(x2 - x3)
        ENDIF
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION no_days                            *
*                          ****************                            *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION no_days(year,mnth,thty_dys)
*----------------------------------------------------------------------*
      INTEGER no_days,year,mnth,thty_dys

      IF (thty_dys.EQ.0) THEN
        IF (mnth.EQ.2) THEN
          IF (mod(year,4).EQ.0) THEN
            no_days = 29
          ELSE
            no_days = 28
          ENDIF
          IF (mod(year,100).EQ.0) no_days = 28
          IF (mod(year,400).EQ.0) no_days = 29
        ELSE
          IF ((mnth.EQ.4).OR.(mnth.EQ.6).OR.(mnth.EQ.9).OR.
     &(mnth.EQ.11)) THEN
            no_days = 30
          ELSE
            no_days = 31
          ENDIF
        ENDIF
      ELSE
        no_days = 30
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION no_day                             *
*                          ***************                             *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION no_day(year,mnth,day,thty_dys)
*----------------------------------------------------------------------*
      INTEGER no_day,year,mnth,day,i,no_days,thty_dys

      no_day = day
      IF (mnth.GT.1) THEN
        DO i=1,mnth-1
          no_day = no_day + no_days(year,i,thty_dys)
        ENDDO
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          ST2ARR                                      *
*                          ******                                      *
*                                                                      *
* Strips leading blanks and first integer from the string which is its *
* argument.                                                            *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE ST2ARR(st1,x,ix,no)
      INTEGER x(ix),ix,i,no
      CHARACTER st1*1000

      DO i=1,ix
        CALL STRIPBN(st1,x(i))
      ENDDO

      no = 0
      DO i=1,ix
        IF (x(i).GT.0)  no = no + 1
      ENDDO

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          STRIPBN                                     *
*                          *******                                     *
*                                                                      *
* Strips leading blanks and first integer from the string which is its *
* argument.                                                            *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE STRIPBN(st1,ans)
      CHARACTER st1*1000
      INTEGER blanks,nb,i,ans,blank,check
      LOGICAL minus

      nb = blanks(st1)
      IF (nb.lt.1000) THEN

      minus = .false.
      IF (ichar(st1(nb+1:nb+1)).EQ.45) THEN
        minus = .true.
        nb = nb + 1
      ENDIF
      IF (nb.GT.0) THEN
        DO i=1,1000-nb
          st1(i:i) = st1(i+nb:i+nb)
        ENDDO
        DO i=1000-nb+1,1000
          st1(i:i) = ' '
        ENDDO
      ENDIF

      check = 0
      nb = blank(st1)
      ans = 0
      DO i=1,nb
        IF ((ichar(st1(i:i)).LT.48).OR.(ichar(st1(i:i)).GT.57))
     &check = 1
        ans = ans + 10**(nb-i)*(ichar(st1(i:i))-48)
      ENDDO

      IF (nb.GT.0) THEN
        DO i=1,1000-nb
          st1(i:i) = st1(i+nb:i+nb)
        ENDDO
        DO i=1000-nb+1,1000
          st1(i:i) = ' '
        ENDDO
      ENDIF

      IF (minus)  ans =-ans

      IF (check.EQ.1) ans = -9999

      ELSE
        ans = -9999
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          STRIPBS                                     *
*                          *******                                     *
*                                                                      *
* Strips leading blanks and first string from the string which is its  *
* argument.                                                            *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE STRIPBS(st1,st2)
      CHARACTER st1*1000,st2*1000
      INTEGER blanks,nb,i,blank

      nb = blanks(st1)
      DO i=1,1000-nb
        st1(i:i) = st1(i+nb:i+nb)
      ENDDO
      DO i=1000-nb+1,1000
        st1(i:i) = ' '
      ENDDO

      nb = blank(st1)
      DO i=1,nb
        st2(i:i) = st1(i:i)
      ENDDO
      st2(nb+1:nb+1) = ' '

      IF (nb.GT.0) THEN
        DO i=1,1000-nb
          st1(i:i) = st1(i+nb:i+nb)
        ENDDO
        DO i=1000-nb+1,1000
          st1(i:i) = ' '
        ENDDO
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTUINE STRIPB                          *
*                          ******************                          *
*                                                                      *
* Strips leading blnaks of its argument.                               *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE STRIPB(st1)
      CHARACTER st1*1000
      INTEGER blanks,nb,i

      nb = blanks(st1)
      IF (nb.GT.0) THEN
        DO i=1,1000-nb
          st1(i:i) = st1(i+nb:i+nb)
        ENDDO
        DO i=1000-nb+1,1000
          st1(i:i) = ' '
        ENDDO
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION blank                              *
*                          **************                              *
*                                                                      *
* 'blank' returns the number of characters before the space in the     *
* string which is its argument.                                        *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION blank(st1)
*----------------------------------------------------------------------*
      CHARACTER st1*1000
      INTEGER blank

      blank = 0
10    CONTINUE
      blank = blank + 1
      IF ((blank.LE.100).AND.(ichar(st1(blank:blank)).NE.32)
     &     .AND.(ichar(st1(blank:blank)).NE.9))  GOTO 10
c space and tabulation
      blank = blank - 1

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION last_blank                         *
*                          *******************                         *
*                                                                      *
* 'last_blank' returns the number of characters in st1.                *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION last_blank(st1)
*----------------------------------------------------------------------*
      CHARACTER st1*1000
      INTEGER last_blank

      last_blank = 1000
10    CONTINUE
      last_blank = last_blank - 1
      IF (last_blank.GE.1) THEN
        IF ((ichar(st1(last_blank:last_blank)).EQ.32).OR.
     &(ichar(st1(last_blank:last_blank)).EQ.9))  GOTO 10
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION blanks                             *
*                          ***************                             *
*                                                                      *
* 'blanks' returns the number of leading blanks.                       *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION blanks(st1)
*----------------------------------------------------------------------*
      CHARACTER st1*1000
      INTEGER blanks

      blanks = 0
10    CONTINUE
      blanks = blanks + 1
      IF (blanks.LE.1000) THEN
        IF ((ichar(st1(blanks:blanks)).EQ.32).OR.
     &(ichar(st1(blanks:blanks)).EQ.9)) GOTO 10
      ENDIF
      blanks = blanks - 1

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION n_fields                           *
*                          *****************                           *
*                                                                      *
* Reurns the number of space delimeted fields.                         *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION n_fields(st1)
*----------------------------------------------------------------------*
      CHARACTER st1*1000,st2*1000,st3*1000
      INTEGER blanks,n_fields

      n_fields = 0
      st2 = st1

10    CONTINUE
      IF (blanks(st2).LT.1000) THEN
        CALL STRIPBS(st2,st3)
        n_fields = n_fields + 1
        GOTO 10
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE IN2ST                            *
*                          ****************                            *
*                                                                      *
* 'in2st' returns the string value of its integer argument.            *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION in2st(int1)
*----------------------------------------------------------------------*
      INTEGER length,loc,int,int1
      PARAMETER(length=1000)
      CHARACTER in2st*(length)

      int = int1

      DO loc=1,length
       in2st(loc:loc) = ' '
      ENDDO

      loc = length
30    in2st(loc:loc) = char(ichar('0') + mod(int,10))
      int = int/10
      loc = loc - 1
      IF (int.GT.0)  GOTO 30

      RETURN
      END

*----------------------------------------------------------------------*
      FUNCTION ntags(st1,st2)
*----------------------------------------------------------------------*
      CHARACTER st1(100)*1000,st2*1000,st3*1000
      INTEGER ntags,stcmp,i,j

      i = 0
10    CONTINUE
        i = i + 1
        st3 = st1(i)
        j = stcmp(st2,st3)
      IF ((j.EQ.0).AND.(i.LT.50)) GOTO 10

      IF (j.EQ.1) THEN
        ntags = i
      ELSE
        ntags = -9999
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
      FUNCTION stcmp(st1,st2)
*----------------------------------------------------------------------*
      CHARACTER st1*1000,st2*1000
      INTEGER k,stcmp

      stcmp = 1
      k = 0
10    CONTINUE
        k = k + 1
        IF (((ichar(st1(k:k)).EQ.0).OR.(ichar(st1(k:k)).EQ.32)
     &                             .OR.(ichar(st1(k:k)).EQ.9))
     &.AND. ((ichar(st2(k:k)).EQ.0).OR.(ichar(st2(k:k)).EQ.32)
     &                             .OR.(ichar(st2(k:k)).EQ.9))) THEN
           stcmp = 1
           GOTO 20
        ENDIF
        IF (st1(k:k).NE.st2(k:k)) THEN
          stcmp = 0
          GOTO 20
        ENDIF
      GOTO 10
20    CONTINUE

      RETURN
      END

*----------------------------------------------------------------------*
      SUBROUTINE RANDOMV(years,yr0,yrf,idum)
*----------------------------------------------------------------------*
      INTEGER yr0,yrf,years(yrf-yr0+1),idum,ranv,ind(500),i,i1,j

      DO i=1,yrf-yr0+1
        ind(i) = i
      ENDDO

      DO i=1,yrf-yr0+1
        i1 = ranv(1,yrf-yr0+2-i,idum)
        years(i) = ind(i1)+yr0-1
        DO j=i1,yrf-yr0+1-i
          ind(j) = ind(j+1)
        ENDDO
      ENDDO

      RETURN
      END

*----------------------------------------------------------------------*
      FUNCTION ranv(i,j,idum)
*----------------------------------------------------------------------*
      REAL*8 ran1
      INTEGER i,j,ranv,idum

      ranv = int(ran1(idum)*(j-i+1))+i

      RETURN
      END

*----------------------------------------------------------------------*
      FUNCTION ran1(idum)
*----------------------------------------------------------------------*
      INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
      REAL*8 ran1,AM,EPS,RNMX
      PARAMETER(IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,
     & NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2E-7,RNMX=1.-EPS)
      INTEGER j,k,iv(NTAB),iy
      SAVE iv,iy
      DATA iv /NTAB*0/, iy /0/

      IF (idum.le.0.or.iy.eq.0) THEN
        idum = max(-idum,1)
        DO j=NTAB+8,1,-1
          k = idum/IQ
          idum = IA*(idum-k*IQ)-IR*k
          IF (idum.lt.0)  idum = idum + IM
          IF (j.le.NTAB)  iv(j) = idum
        ENDDO
        iy = iv(1)
      ENDIF
      k = idum/IQ
      idum = IA*(idum - k*IQ) - IR*k
      IF (idum.lt.0)  idum = idum + IM
      j = 1 + iy/NDIV
      iy = iv(j)
      iv(j) = idum
      ran1 = min(AM*iy,RNMX)

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION round                              *
*                          **************                              *
*                                                                      *
* 'round' calculates the nearest integer value to the argument.        *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION round(x)
*----------------------------------------------------------------------*
      REAL*8 x,rem
      INTEGER round

      rem = abs(x - real(int(x)))

      IF (x.GT.0.0d0) THEN
        IF (rem.GT.0.5d0) THEN
          round = int(x) + 1
        ELSE
          round = int(x)
        ENDIF
      ELSE
        IF (rem.LT.0.5d0) THEN
          round = int(x)
        ELSE
          round = int(x) - 1
        ENDIF
      ENDIF

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE MATCHECK                         *
*                          *******************                         *
*                                                                      *
* MATCHECK computes the Euclidean distance between the vector          *
* [a,b,c,d] and the 'n' rows of 'x'. The minimum distance is stored in *
* 'check' and the row index is stored in 'ind'.                        *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE MATCHECK(x,a,b,c,d,check,ind,n)
*----------------------------------------------------------------------*
      REAL*8 x(n,4),a,b,c,d,check,temp
      INTEGER ind,n,i

      check = 100.0
      DO 10 i=1,n
        temp = max(abs(x(i,1) - a),abs(x(i,2) - b),abs(x(i,3) -
     & c),abs(x(i,4) - d))
        IF (temp.LT.check) THEN
          check = temp
          ind = i
        ENDIF
10    CONTINUE

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE PILE4                            *
*                          ****************                            *
*                                                                      *
* PILE4 puts the row vector [a,b,c,d] at the top of the n*4 matrix 'x' *
* and shifts the other rows down one, dumping the last.                *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE PILE4(x,a,b,c,d,n)
*----------------------------------------------------------------------*
      REAL*8 x(n,4),a,b,c,d
      INTEGER n,i,j

      DO i=1,n-1
        DO j=1,4
          x(n-i+1,j) = x(n-i,j)
        ENDDO
      ENDDO
      x(1,1) = a
      x(1,2) = b
      x(1,3) = c
      x(1,4) = d

      RETURN
      END

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE PILE1                            *
*                          ****************                            *
*                                                                      *
* PILE1 puts the scalar 'a' at the head of the 'n' dimensional vector  *
* 'x' and shifts the other elements down one, loosing the last.        *
*----------------------------------------------------------------------*
      SUBROUTINE PILE1(x,a,n)
*----------------------------------------------------------------------*
      REAL*8 x(n),a
      INTEGER n,i

      DO i=1,n-1
        x(n-i+1) = x(n-i)
      ENDDO
      x(1) = a

      RETURN
      END


text:
      SUBROUTINE ATMINI(ISTART,ISTOP)
C
C Subroutine sets coordinate arrays and harmonic constraint array
C to default values for atom numbers between ISTART and ISTOP.
C
C Author: Axel T. Brunger
C
      IMPLICIT NONE
C input/output
      INCLUDE 'cns.inc'
      INCLUDE 'mtf.inc'
      INCLUDE 'cnst.inc'
      INCLUDE 'coord.inc'
      INCLUDE 'coordc.inc'
      INCLUDE 'deriv.inc'
      INCLUDE 'heap.inc'
      INTEGER ISTART, ISTOP
C local
      INTEGER I
      DOUBLE PRECISION    ANUM
      PARAMETER (ANUM=9999.0D0)
C begin
      DO I=ISTART,ISTOP
      X(I)=ANUM
      Y(I)=ANUM
      Z(I)=ANUM
      WMAIN(I)=0.0D0
      QMAIN(I)=1.0D0
      XCOMP(I)=ANUM
      YCOMP(I)=ANUM
      ZCOMP(I)=ANUM
      WCOMP(I)=0.0D0
      QCOMP(I)=1.0D0
      KCNSTR(I)=0.0D0
      KZCNSTR(I)=0.0D0
      RMSD(I)=0.0D0
      REFX(I)=ANUM
      REFY(I)=ANUM
      REFZ(I)=ANUM
      FBETA(I)=0.0D0
      DX(I)=0.0D0
      DY(I)=0.0D0
      DZ(I)=0.0D0
      XV(I)=0.0D0
      YV(I)=0.0D0
      ZV(I)=0.0D0
      IMOVE(I)=0
      END DO
      CALL ATMIN2(HEAP(IINTER(1)),ISTART,ISTOP)
      RETURN
      END
C
      SUBROUTINE ATMIN2(INTERE,ISTART,ISTOP)
C
      IMPLICIT NONE
C I/O
      INTEGER INTERE(*), ISTART, ISTOP
C local
      INTEGER I
C begin
      DO I=ISTART,ISTOP
      INTERE(I)=0
      ENDDO
C
      RETURN
      END