text:
The Hospital

Davis Small Animal Hospital has been at its current location since 1978. It has been owned and operated by Dr. Janet Edson for over 20 years.  Her conviction has always been to provide the best possible care for our clients.  To accomplish this, the hospital has the most modern equipment available and the most skilled staff possible.  Dr. Edson cares for animals over their whole lives and she has vast experience in geriatric medicine to provide the best lives for our older patients.  Check out our website http://www.dsah1617.com

Dr. Edson also has a flair for design. Please stop by and check out our beautiful facility

 Doctors

Dr. Janet Edson received her Doctor of Veterinary Medicine degree in 1988  from the University of California at Davis, perhaps the premier veterinary college in the US. She worked for two years at a hospital in Sacramento and then bought the Davis Small Animal Hospital in order to provide the best possible medical care to her clients, the kind of care she provides for her own animals.  She is an outstanding veterinarian with a true passion for her patients. She loves the older animals and through her expertise is able to provide them with years of quality life.

Dr. Kirstin Murphy joined the DSAH about 1 year ago.  She graduated from UC Davis School of Veterinary Medicine in 2000.   She left Davis for a period of 7 years and returned to Davis when her husband, also a veterinarian, became a faculty member at the UC Davis School of Veterinary Medicine. Dr. Murphys primary veterinary interest is dentistry and she has developed outstanding skills in this area.  One of the the things that attracted Dr. Murphy to the DSAH is the top of the line technology to diagnose and treat any dental problems of your family pets.

 Support Staff

We have the greatest staff in the world. They love to meet new people, but be sure to bring your four legged family memebers.

 Feline Staff

There are several live in clients. One or more will greet you when you come visit.

  See our Veterinary Hospitals page for other vet services within Davis.

Users/StevenDaubert sez that MUGA was borded there for about a week and has had some vet checkups at the DSAH, The Dr. was good according to his parents.

20051014 12:31:52 nbsp I have taken two rats here for the same problem: both developed tumors. The first time I went in, the vet was over an hour late. But he euthanized my rat for free (normally its like $35), so I decided not to hold it against him. With the second rat, the vet tried to convince me to pay for expensive tumorremoval surgery, and declined my request to have her euthanized because she was still fiesty (despite the fact that the tumor was starting to get infected). I ended up taking her home and euthanizing her myself (humanely). I will not return to this place. Users/AlexPomeranz

20051223 10:35:01 nbsp I have a dog and a cat, and have taken them to this place over the past five years. People are always nice, from the vet to the techs to the receptionist. The treatment is excellent as far as I can tell. I have not tried other places in Davis, but have gone to different places in different cities over the past twenty years, and this is the best that I have experienced. Users/HughToppe

20061106 10:36:58 nbsp I have a cat and have taken it here a few times for urination and fecal problems. On both occasions, I was told that numerous tests were needed. When I asked if they were all necessary for the one problem, they treated me as if I did not have the animals best interest in mind. On another occasions they charged an extra fee for a flea treatment that I did not ok. When I asked about it, the money would not be refunded. I would not recommend this hospital. The doctor at the Aggie Animal Clinic in Dixon is amazing, he is the best vet that I, and other pet owners I know, have ever had. Users/JohnFranklin

20061201 15:24:19 nbsp My family has brought our pets (cats and dogs) to Davis Animal Hospital for over 20 years. We have always found the staff to be caring, compassionate and professional, from the receptionist to the techs to the vets themselves. Dr. Edson and Dr. Sobrano are excellent. I have never felt pressured to have tests performed on my animals. Moreover, Davis Animal Hospital makes housecalls for euthanasia, which means that pets can be put to sleep without a traumatic and stressful trip to the vet. I cannot give a high enough recommendation to this clinic!!!! Users/CatherineHess

20061228 12:38:16 nbsp I wouldnt recommend this veterinary hospital to anyone. I brought my rabbit here to be treated for mites and over $300 and one round of treatments later, she still has mites. The vet failed to tell me that I need to steam clean my carpet to get rid of mites living in it (this was after he first told me all I needed to do was vacuum it, which I uselessly did). I searched online and found out youre not even supposed to steam clean the carpet because the humidity helps the mites breed. Thanks alot!! Not to mention, they charged me a ridiculous amount of money for all sorts of things. Best of all, the vet acted like it was my fault that the treatments hadnt worked. Yes, thats it, becuase I totally wanted to waste $350 going to this shady place. Users/CarolShu

Ive regularly visited Dr. Soberano at the Davis Small Animal Hospital after getting Lula Belle, our Corgi puppy; Dr. Soberano was great, and Id recommend him to anyone as a kind, competent Vet. However, even with an established appointment, I waited an average of 20 minutes before each of my ~6 appointments. I have to admit, after a long day at the office, this became a bit much. So, although they are well meaning, they need a bit of help on the organizational front, becuase the last time I went in (to drop off something), there were 6 people in the waiting area, and no on at the reception desk. They all looked like theyd been there awhile, too. So, keep that in mind of you go to this place. Id recommend going to the Woodland Vet Hospital myself; they are very organized. You can visit their website at www.woodlandvethosp.com. Dr. Larson did Lus spay, and did a great job. Kudos to their whole operation; nice, organized folks! Users/CristinaWilson

20070405 14:09:37 nbsp I did not have a great experience with Dr. Gustavo Soberano. He suggested a teeth surgery that was so expensive and explained that it was absolutely necessary. My dog is 11 years old and I didnt feel that it was the right decision. So, I waited and its been three months and she completely perfect. So, unless you have the money to spend on something unnecessary I dont recommend going there. Users/CTai

20070305 10:23:08 nbsp I took our hamster in because her eye had a huge infection and shed lost half the fur on one side of her face. Dr. Edson was really good and the staff professional. They called to check up for four days thereafter, which impressed me. The hamster recovered, but I would have given them high marks even if she hadnt made it. Conscientious group, in my opinion. Users/RobertBoole

20070529 22:16:57 nbsp I also remember waiting here and being told I needed unnecessary meds, vaccines, etc. I havent gone in a few years but there was a reason. Users/DavisGirl

20080223 21:55:09 nbsp After playing phone tag with UC Davis all week with no success due to their long wait list, I brought my two rats here to Davis Animal Hospital.  They got me in the same day I called, and treated them for parasites.  The care from Dr. Soberano was exceptionally good, and very reasonably priced.  He spent a lot of time answering my questions  and I had a lot.  My rats had begun to fight the week before, and he gave me suggestions to stop their fighting WITHOUT costly neutering, which was suggested to me by an online rat forum.  My boys are now feeling substantially better, and with Dr. Soberanos advice regarding adding a variety of new toys and additional food and water sources, they are no longer fighting!

Nevertheless, he did offer to do the surgery if they continue to fight.  He even called back to follow up.  What more could I ask for in rat care? Users/incognitoTA

20080506 09:08:20 nbsp I used to take my dog here  since she was a puppy 11 years ago. After this place changed ownership I had to take my dog in to have a foxtail removed from her nose. Not the first time (at least twice before). But previously the cost was always less than $150  including ~$60 for anesthesia. This time the bill was $510! There was no cost estimate before the procedure (I naively assumed the cost would be in the same ballpark as before). They charged $130 for anesthesia, PLUS fluids $130 (never necessary before), PLUS blood tests $95 (also never needed before). Havent been back since. Users/BridgetOflaherty

20080507 11:28:55 nbsp I used them for 14 years with my two dogs.  When it was primarily Dr Edson and Dr Ibsen.  They performed surgeries and took care of both my family members very well.  For the most part the tech staff were incredibly helpful and kind.

I believe they are a bit overpriced compared to other vets in town but they do provide great care.  I cant say I had the best experience with Dr Soberano and I probably would choose another vet for any new pet I may get but if you live near them they are certainly worth looking into. Users/loneshark

20080808 10:34:49 nbsp When reading all of the comments the consensus is overpriced and excessive in charges. I would agree. I took my dog here for care and was told that they would need to do a series of tests that would cost almost $500 dollars. I was given a breakdown of the charges and decided on doing some of the tests and not others. When finally billed the charges were more than the estimate and mysteriously there were additional charges that were not even included on the original treatment plan. I was also offered medicine from them that was past its expiration date. When I inquired about that I was told not to worry about it. I decided to get the meds elsewhere and paid almost half what this office was going to charge me. I will never take my animals back here. The vets could be top notch but their apparent efforts to maximize revenue feels to me like a gross diservice to the clients. Users/pedalpower

20080808 17:55:58 nbsp Dr. Edson is an incredible woman and doctor (and yes, she sure does have over 20 cats as well as other animals in her home...Ive met them all).  They are a bit pricey, but you get great service.  If I still had my cat, Bucky, Id still go here... Users/SunjeetBaadkar

20081129 08:27:30 nbsp Dr. Gustavo Soberano is probably the best vet I have found for my rats. Every time I take any of my rats in he explains everything very well and takes time to answer my questions. If you have a rat that needs to see a vet, I would definitely go here.  Users/Bri916

20090411 14:57:45 nbsp First off, Gustavo is no longer working there.  We originally started going here a couple years ago because we knew Gustavo personally.  We loved him as a person and as a vet.  Today though I was completely let down by the office.  I called in right when they opened because my kitty who is dying of kidney failure needed to be put to sleep.  He had been going downhill all week but I was waiting for the right time and we realized last night that it was time.  So I called and they told me they were overbooked and refused to see me.  Now personally, I feel like patients with routine vaccinations or things like that can be rescheduled.  The refused to try and fit me in or anything.  They told me I could come in next weekend.  Sorry lady, my cat is not going to make it until then.  I was very diappointed that they could not take the 15 minutes to put my suffering cat to rest.  After learning that Gustavo is no longer there and they way they treated me today I think I will be looking for a new vet.  My kitty ended up dying in my arms a few hours later and I took him there to be cremated but I dont think I will go there again after I pick up his ashes. Users/MsSteffee

20090420 09:02:56 nbsp With Dr. Janet Edson’s veterinary medical skill, compassion, and flexibility in treatment we have enjoyed seven happy months (and counting!) with our beloved old dog.  I couldn’t be more grateful.

As a chemotherapy patient, our dog has visited Davis Small Animal Hospital far more frequently than he would for checkups and occasional illness and mishaps.  He’s a particularly sensitive animal and rather shy, and I worried that these repeated chemo appointments would distress him a lot.  To see him look forward to seeing Dr. Edson is really heartwarming.  He stands with his nose pressed against the door and listens for her.  When she arrives he wags his tail and he’ll go off to the treatment room without hesitation if Dr. Edson invites him in.

As pet owners, our dog’s quality of life is the key issue in all decisions we make for him.  Dr. Edson has kept us informed and involved in every aspect of his chemotherapy and, recently, in the decision to discontinue clinical chemo treatments. When he had an significant adverse reaction to one of the more effective drugs during the winter, she agreed to modify the protocol to protect him from a repeat of that experience.  With careful monitoring his lymphoma has stayed in remission and he has had many happy weeks since then.  We have never felt that Dr. Edson was battling the disease at the expense of the patient’s quality of life; she has pinpointed what treatments help him the most and trouble him the least.  This is extremely important to us, and we have enormous confidence in Dr. Edson’s judgment.

We understand that our pet is nearing the end of his life and, as hard as it would be on us, we are determined to help him die peacefully if he comes to the point where staying alive means suffering.  Knowing that Dr. Edson would euthanize him at home is a great comfort to us, and just another reason that we are so grateful for her compassionate professionalism.
 Users/SusanWilcox

20090424 14:20:41 nbsp We have taken our many cats and dogs to Davis Animal Hospital for over 20 years, for everything from annual vaccinations to many (over the years) euthanasias and the accompanying preceding treatments for extending life when facing terminal illness.  During all of this we have also visited varioius other clinics and specialists  we will never go to UC Davis again!  and have had many chances to compare treatments and diagnosis.  Janet Edson, in our opinion, is one of the best diagnosticians in the northern half of the state, a veterinarian that actually listens to her clients and carefully assesses each problem, all the while keeping the client informed of the steps she is suggesting, and why.  She always lays out the options, investigates new modes of treatment, consults with specialists when necessary, and clearly communicates the issues regarding BOTH quality of life and potential costs.  She is also the most caring and supportive veterinarian we have encountered. We also respected Gustavo Soberanos skill and were sad to hear he had left.  The clinic is wellrun, with excellent support staff, something we could not have said before Dr. Edson assumed complete ownership a couple of years ago.   Pat Erigero and Tom Matoff Users/TomMatoff

20090511 16:14:47 nbsp wow.. first off as compared to the other places in town this is not that expensive. if you guys dont look into what your doing and signing up for when you take you animals somewhere, its your fault, do not fault the vet because your to lazy to investigate what is required when giving your pet to a vet for  a surgery or a check up. i have used this vet for years and i have never once had a bad experience with them, in fact a few months ago my cat jack had a urinary track infection and could not urinate and we ended up taking him to a place that wanted $5000 to do a surgery and then $250/day to look after him while he recovered. we talked to the vets her and not only did we get he surgery done for under $700, but the vet actually took my cat home with her to take care of him because he was to sick to be left by himself, and charged only $50/day to do so. i cant think that this place could get anything less than a shinning review from anyone that bothers to do any kind of research into the kind of treatment that their pet would be receiving. i have taken multiple pets here and every time i have had a pleasant experience, and i would HIGHLY recommended this place to anyone that want the best for their pets. Users/jaksin

20090701 15:43:54 nbsp I have taken two cats to Dr. Edson over the years, and have found her very supportive and knowledgeable. She has always presented me with a range of options, and costs, and helped to me evaluate the cheapest yet most probable route to take toward achieving a diagnosis. I currently have a cat with an unexplained respiratory problem  a specialist looked for a polyp, and upon not finding one, recommended a cat scan (no pun intended), which costs over $1000. Dr. Edson has helped me create a plan of attack toward finding a diagnosis for this problem without the cat scan, which is way out of my budget. While the tests have still been expensive, with many tests coming back negative, I understood her reasoning for trying things in the order that we did, based on the cats symptoms and what i could afford. She often called me and talked at length about my cats symptoms and progress, and I feel she has a genuine concern for him. And the best news is that the recent test came back positive, and there is likely a fairly simple effective antibiotic cure! I am very thankful to Dr. Edson for her ideas and persistance, and would highly recommend her to others with cats  she knows a lot and has a genuine dedication Users/farmedgirl

20100216 22:40:06 nbsp Dr. Edson and Dr. Murphy are both excellent veterinarians who have years of practicing veterinary medicine under their belts. Whenever a procedure is recommended, you can always ask for an estimate. You dont necessarily have to do every procedure that is recommended, and both doctors are more than happy to negotiate different methods to treat your pets (especially good for students!). A lot of the recommended procedures are just precautions, but if you dont want to pay for it or dont have the means to pay for a procedure, then you dont have to! Duh.  Users/JYuki

20110430 22:00:23 nbsp I was humbled by the staffs compassion and efforts to save a stray cat I came in with. They were amazing at working out costs with me since I was limited. They really went the distance for this animal, all of them from the receptionist, technician to Dr. Edson.  Users/dizzyditz

20110918 13:27:51 nbsp Ive been taking my two dogs here over the past year and have been very satisfied. From parasite infections to surgeries, the care my dogs have received from Dr. Edson and Dr. Murphy has been outstanding. Its clear that both of these vets of them love their work and are very qualified doctors. Both have explained procedures, risks, and costs clearly and carefully and been understanding re: my limited financial resources (Im a grad student).
The vet techs and front office folks have always been friendly and professional as well. They have made us feel welcome and have been flexible in scheduling for both emergencies and nonurgent care. I have been to many vet clinics in Davis and I strongly recommend Davis Small Animal Hospital. Users/BenReeb

20120613 08:02:13 nbsp I was disappointed to learn I was misled by the clinics name  Dr. Edson doesnt treat rats. Users/Willikers
 In the veterinary field, small animal or small animal general practice refers to dogs and cats.  Rodents, birds, reptiles, and so on are generally called exotics. Users/TomGarberson
  Comments from 20052008 indicate they used to treat rodents (at least rats and hamsters), but it was by Dr. Soberano who is no longer with this practice. Users/edwins ES

20130902 16:13:08 nbsp I bring my furry exotic pet here for regular check ups.  She recently had to have something stuck in her intestine surgically removed, and that went as smoothly as can be imagined.  Dr. Keller is very considerate and attentive to both me and my pet. (And shes cute too!)  Yes, the cost is certainly higher than youd pay anywhere else, but you indeed get your moneys worth in terms of the best care for you pet. Users/DanielPfister


text:
There are plenty of Stop Signs in town, but some people Running Stop Signs just don’t stop.

The http://www.dmv.ca.gov/pubs/hdbk/pgs17thru18.htm#trafficsigns California Driver Handbook has this to say about stop signs: Eightsided red STOP signs mean you must make a full stop whenever you see a STOP sign. Stop before entering a crosswalk or at a white “limit line” which is a wide white line painted on the street. If a crosswalk or limit line is not painted on the street, stop at the corner.

More information about http://www.dmv.ca.gov/pubs/hdbk/pgs16thru17.htm#intersections right of way at intersections, including those controlled by stop signs, can be found in the Handbook.

There is a difference between fourway stops, as seen mostly in down town, and twoway stops as seen bordering down town on more minor streets. There is an even bigger difference in a Cactuar Sign, as those have no jurisdiction over our roads. Some local signs have a Shark Finning secret activist agenda as well.

The Oregon Legislature is currently considering adoption of a law similar to one in Idaho that introduced what’s known today as the http://vimeo.com/4140910?pgembed&sec Idaho stop, which allows bicyclists to treat stop signs as yield signs. No word yet on if and when California or Davis will consider such a law. However, if it passes in Oregon, it may not be far off.

The stopclap game would not be possible without the existence of these noble landmarks.

20071002 10:36:49 nbsp What, no pictures of various stop signs in town?  :) Users/CovertProfessor
  Maybe a list of all stop signs in Davis.  On second thought, thatd be just as tedious and repetitive as getting pictures of lots of stop signs.  Either would be cool to see, but I wouldnt want to do it. Users/BrettHall

20071002 10:39:05 nbsp There is a page on stop signs. Wow. Users/JoseBleckman

20071010 08:09:20 nbsp Someone should note the difference between all way stops, as seen mostly in down town, and the ... notallway stops as seen bordering down town on more minor streets. Users/DavidPoole

20080318 13:35:23 nbsp so what if one encounters a 7 sided stop sign, or a 6 or 9 what about a 10???? Users/DevinCastellucci

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      subroutine map_aoml_sub(nilaps,njlaps,aoml_path_in,vrc_outdir    ! I
     1                       ,i4time_sys,laps_cycle_time               ! I
     1                       ,istatus)                                 ! O

      real lat(nilaps,njlaps)
      real lon(nilaps,njlaps)
      real topo(nilaps,njlaps)
      real rlaps_land_frac(nilaps,njlaps)

      real dbz(nilaps,njlaps)

      integer cvt_wfo_fname13_i4time

      character fname_in*140, path*140, basename*40
      character*13 wfo_fname13
      character*200 aoml_path_in
      character*7 vrc_outdir

      character*255 c_filespec_in,vrc_full_path
      integer max_files
      parameter(max_files = 3000)
      character*255 c_fnames_in(max_files),c_fnames_out(max_files)
!     integer i4times_in(max_files)
      integer i4times_out(max_files)

      logical l_match

      call get_r_missing_data(r_missing_data,istatus)

c read in laps lat/lon and topo
      call get_laps_domain_95(nilaps,njlaps,lat,lon,topo
     1                       ,rlaps_land_frac
     1                       ,grid_spacing_cen_m,istatus)
      if(istatus .ne. 1)then
          write(6,*)' Error getting LAPS domain'
          istatus = 0
          return
      endif

      i4time_proc_end  = i4time_sys + laps_cycle_time/2 + 1800
      i4time_proc_strt = i4time_sys - laps_cycle_time/2 - 1800

!     Get times of output files
      i_vrc = 2
      call get_vrc_full_path(i_vrc,vrc_outdir
     1                        ,vrc_full_path,lenv,istatus)
      if(istatus .ne. 1)then
          write(6,*)' Return from map_aoml_sub without AOML processing'
          return
      endif

      call get_file_times(vrc_full_path,max_files,c_fnames_out
     1                   ,i4times_out,i_nbr_files_out,istatus)

!     Get names and times of input files
      call s_len(aoml_path_in,lenp)
      if(lenp .eq. 0)then
          write(6,*)'map_aoml_sub: aoml_path_in has zero length'
          istatus = 0
          return
      endif

      c_filespec_in = aoml_path_in
      call get_file_names(c_filespec_in,i_nbr_files_in,c_fnames_in
     1                   ,max_files,istatus)

      if(i_nbr_files_in .eq. 0)then
          write(6,*)'No AOML files available'
          istatus = 0
          return
      endif

      do ifile_in = 1,i_nbr_files_in

          write(6,*)

!         basename = 'lf050705I1_stm_230058.swp'
!         call s_len(basename,lenb)
!         fname_in = path(1:lenp)//'/'//basename(1:lenb)

!         Split out basename from full file name
          fname_in = c_fnames_in(ifile_in)
          call s_len(fname_in,lenf)

          if(fname_in(lenp:lenp) .eq. '/')then
              lenf_start = lenp+1
          else
              lenf_start = lenp+2
          endif

          if(lenf .ge. lenf_start)then
              basename = fname_in(lenf_start:lenf)
          else
              write(6,*)' lenp/lenf mismatch ',lenp,lenf_start,lenf
              istatus = 0
              return
          endif

!         Obtain i4time corresponding to the basename, we handle the hours
!         and minutes separately since AOML can go to more than 24 hours
          wfo_fname13 = '20'//basename(3:8)//'_'//basename(16:19)
          write(6,*)'wfo_fname13 = ',wfo_fname13

          wfo_fname13 = '20'//basename(3:8)//'_'//'0000'

          read(basename(16:17),*)ihour
          read(basename(18:19),*)imin

          i4time_file_in = cvt_wfo_fname13_i4time(wfo_fname13)

          i4time_file_in = i4time_file_in + ihour*3600 + imin*60

          write(6,*)' ihour/imin/i4time_file_in = '
     1               ,ihour,imin,i4time_file_in

          if(i4time_file_in .ge. i4time_proc_strt .AND.
     1       i4time_file_in .le. i4time_proc_end        )then

!             Check for a match with output file times
              l_match = .false.
              do ifile_out = 1,i_nbr_files_out
                  if(i4time_file_in .eq. i4times_out(ifile_out))then
                    l_match = .true.
                  endif
              enddo ! ifile_out

              if(.not. l_match)then
                  write(6,*)' No output match - processing this time'
                  call map_aoml_sweep(nilaps,njlaps,lat,lon,dbz,fname_in
     1                           ,r_missing_data
     1                           ,rlat_radar,rlon_radar)

                  write(6,*)' calling put_vrc ',vrc_outdir

                  call put_vrc(i4time_file_in,comment_2d
     1                        ,rlat_radar,rlon_radar,rheight_radar
     1                        ,lat,lon,topo
     1                        ,dbz,nilaps,njlaps,i_vrc
     1                        ,vrc_outdir,r_missing_data,istatus)

              else
                  write(6,*)' Output already exists - skip this time'

              endif

          else
              write(6,*)' Outside Time Window'

          endif

      enddo ! ifile_in

      istatus = 1

      return
      end

      subroutine map_aoml_sweep(nilaps,njlaps,lat,lon,dbz,name
     1                         ,r_missing_data
     1                         ,olat,olon)

      real lat(nilaps,njlaps)
      real lon(nilaps,njlaps)
      real dbz(nilaps,njlaps)

      real sum(nilaps,njlaps)
      integer npt(nilaps,njlaps)

      CHARACTER      keyword*4, fltname*8, stmname*12, radarid*4,
     +               trackname*32, createtime*32, ramname*28,
     +               name*140, jfile*140

      parameter (imax=240)
      parameter (jmax=240)
      parameter (max_x=imax)
      parameter (max_y=jmax)
      INTEGER*2    zarray(0:max_x-1,0:max_y-1) !ROW OF DBZ VALUES TO BE
      INTEGER*2    kpac(32767)
      lunit = 1
      luout = 2

      write(6,*)' filename = ',name

      ierr = 0

      CALL READHEAD(luout, name, lunit, ierr, keyword, fltname,
     +  stmname, radarid, trackname, createtime, ramname, imax, jmax,
     +  kmax, nsweeps, nmosmflag, iunfoldflag, intattflag, ieditflag,
     +  iextra2, iextra3, stime, etime, olat, olon, sx, sy, sz, xdis,
     +  ydis, z0, rot, radaralt, calibco1, calibco2, azmcor, elcor,
     +  thresh, dbzrs, pcor, dcor, rcor, starthorelev, htbb, dbb)
C     OPENS RADAR DATA FILE AND READS RADAR HEADER DATA VALUES.
C     PAUL A. LEIGHTON, USDC/NOAA/AOML/HRD, 4 JUN 1991

      if(ierr .ne. 0)then
          write(6,*)' Note: ierr from AOML READHEAD = ',ierr
          return
      endif

      write(6,*)' stmname = ',stmname
      write(6,*)' olat/olon = ',olat,olon
      write(6,*)' imax,jmax = ',imax,jmax
      write(6,*)' xdis,ydis,rot = ',xdis,ydis,rot
      write(6,*)' sx,sy = ',sx,sy
      write(6,*)' radaralt = ',radaralt

      CALL PASSXCMP(lunit, imax, jmax, max_x, max_y, zarray)

!     write(10,*)zarray

      icen = imax/2
      jcen = jmax/2

      elev = 0.
      rheight_radar = 3000.

!     Initialize arrays
      sum = 0.
      npt = 0

!     Use pixel averaging onto laps grid
      do i = 0,imax-1
      do j = 0,jmax-1

        if(zarray(i,j) .gt. -999)then
          riradar = float(i-icen)
          rjradar = float(j-jcen)
          range = sqrt(riradar**2 + rjradar**2) * sx * 1000.
          azimuth = atan3d(riradar,rjradar) + rot
          call radar_to_latlon(rlat,rlon,height_grid
     1                  ,azimuth,range,elev
     1                  ,olat,olon,rheight_radar)

          call latlon_to_rlapsgrid(rlat,rlon,lat,lon,nilaps,njlaps
     1                            ,rilaps,rjlaps,istatus)

          ilaps = nint(rilaps)
          jlaps = nint(rjlaps)

          if(ilaps .ge. 1 .and. ilaps .le. nilaps .and.
     1       jlaps .ge. 1 .and. jlaps .le. njlaps       )then
              sum(ilaps,jlaps) = sum(ilaps,jlaps) + zarray(i,j)
              npt(ilaps,jlaps) = npt(ilaps,jlaps) + 1
!             write(6,*)i,j,ilaps,jlaps,npt(ilaps,jlaps),zarray(i,j)
          endif
        endif

      enddo ! j
      enddo ! i

!     Divide arrays
      do il = 1,nilaps
      do jl = 1,njlaps
          if(npt(il,jl) .gt. 0)then
              dbz(il,jl) = sum(il,jl) / float(npt(il,jl))
          else
              dbz(il,jl) = r_missing_data
          endif
      enddo ! jl
      enddo ! il

      return
      END

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
Walnut trees (Juglans spp) are deciduous trees belonging to the walnut family (Juglandaceae), which includes hickory trees (Carya). The 21 Juglans species all provide edible walnuts which can be further divided into the following:
 English/Persian walnuts (Juglans section, containing only J. regia)
 Black walnuts (Rhysocaryon section, typically J. nigra)
 Butternuts (Trachycaryon section, containing only J. cineria)
 Heartnuts (Cardiocaryon section).
The name walnut derives is a corruption of the French Gaul nut and are native to Asia Minor and southeastern Europe. Most are grown for their beauty, timber and some for their edible nuts. Walnuts produce both male and female flowers on the same tree which open at different times; because of their offset flowering cycles, trees must be crosspollinated. The flowers are green, with males growing in long catkins and females forming small clusters. Walnut leaves are one to twofeet long, pinnate, and formed of 24 ovoid lanceshaped leaflets. Walnuts are typically 23 in diameter and surrounded by a fleshy, greenish husk during the summer; by fall, they ripen and drop from the trees.

Black walnuts seem to be all over Davis. Black walnut wood is reddish in color and is frequently used in joinery because of its rot resistance and ease of use in woodworking. Squirrels, roof rats rats and crow migration crows drop and bury the nuts which sprout in weather spring. Though a nonnative species, California produces about 20% of the worlds English walnut crop, and is the only state within the US producing commercially; most of this production comes from the http://en.wikipedia.org/wiki/Central_Valley Central Valley, and about 50% of that production is controlled by http://www.diamondwalnut.com/default.asp Sun Diamond growers coop headquartered in Stockton. Most walnut tree species will flourish in welldrained, loamy soil, and should be gardening pruned between June and December to encourage the formation of a single, central shoot.

To find out what other plants you may see around Davis, take a look at our Town Flora.


text:
!***********************************************************************
!  Integrated Water Flow Model (IWFM)
!  Copyright (C) 2005-2021
!  State of California, Department of Water Resources
!
!  This program is free software; you can redistribute it and/or
!  modify it under the terms of the GNU General Public License
!  as published by the Free Software Foundation; either version 2
!  of the License, or (at your option) any later version.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!  (http://www.gnu.org/copyleft/gpl.html)
!
!  You should have received a copy of the GNU General Public License
!  along with this program; if not, write to the Free Software
!  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
!
!  For tecnical support, e-mail: IWFMtechsupport@water.ca.gov
!***********************************************************************
MODULE TimeSeriesUtilities
  USE MessageLogger
  USE GeneralUtilities
  IMPLICIT NONE

  INTEGER,PARAMETER                   :: ModNameLen = 21
  CHARACTER(LEN=ModNameLen),PARAMETER :: ModName    = 'TimeSeriesUtilities::'

  INTEGER,PARAMETER :: TimeStampLength=16
  INTEGER,SAVE      :: CacheLimit=500 !Default
  INTEGER,SAVE      :: SimulationTimeStep_InMinutes = 0 !Variable that stores the simulation time step length for the conversion of rate-type data read from ASCII file (default is zero)

  PRIVATE
  PUBLIC::TimeStepType                                      , &
          TimeStampLength                                   , &
          IsTimeStampValid                                  , &
          IsTimeIntervalValid                               , &
          IsLeapYear                                        , &
          StripTimeStamp                                    , &
          JulianToTimeStamp                                 , &
          JulianDateAndMinutesToTimeStamp                   , &
          TimeStampToJulianDateAndMinutes                   , &
          TimeStampToJulian                                 , &
          DayMonthYearToJulianDate                          , &
          JulianDateToDayMonthYear                          , &
          ExtractDay                                        , &
          ExtractMonth                                      , &
          ExtractYear                                       , &
          AdjustTimeStampWithYear4000                       , &
          TimeStampToYear4000                               , &
          IncrementTimeStamp                                , &
          IncrementJulianDateAndMinutesAfterMidnight        , &
          DSSStyleDate                                      , &
          DSSStyleHoursAfterMidnight                        , &
          NPeriods                                          , &
          OPERATOR(.TSLT.)                                  , &
          OPERATOR(.TSGT.)                                  , &
          OPERATOR(.TSGE.)                                  , &
          OPERATOR(.TULE.)                                  , &
          CTimeStep_To_RTimeStep                            , &
          TimeIntervalConversion                            , &
          SetSimulationTimeStep                             , &
          SetCacheLimit                                     , &
          SetTSDCacheSize                                   , &
          GetCacheLimit                                     , &
          AdjustRateTypeData                                , &
          LeapYearCorrection                                , &
          RecognizedIntervals_InMinutes                     , &
          RecognizedIntervals                               , &
          GetJulianDatesBetweenTimeStampsWithTimeIncrement

  ! -------------------------------------------------------------
  ! --- TIME STEP DATA TYPE
  ! -------------------------------------------------------------
  TYPE TimeStepType
    LOGICAL                        :: TrackTime          = .FALSE.
    REAL(8)                        :: CurrentTime        = 0.0
    REAL(8)                        :: EndTime            = 0.0
    INTEGER                        :: CurrentTimeStep    = 0
    CHARACTER(LEN=TimeStampLength) :: CurrentDateAndTime = ''
    CHARACTER(LEN=TimeStampLength) :: EndDateAndTime     = ''
    REAL(8)                        :: DeltaT             = 0.0
    INTEGER                        :: DeltaT_InMinutes   = 0
    CHARACTER(LEN=6)               :: Unit               = ''
  END TYPE TimeStepType

  ! -------------------------------------------------------------
  ! --- PARAMETERS
  ! -------------------------------------------------------------
  INTEGER,PARAMETER :: RecognizedIntervals_InMinutes(20) = [1,2,3,4,5,10,15,20,30,60,120,180,240,360,480,720,1440,10080,43200,525600]
  CHARACTER(LEN=6),PARAMETER :: RecognizedIntervals(20) = ['1MIN  ' , &
                                                           '2MIN  ' , &
                                                           '3MIN  ' , &
                                                           '4MIN  ' , &
                                                           '5MIN  ' , &
                                                           '10MIN ' , &
                                                           '15MIN ' , &
                                                           '20MIN ' , &
                                                           '30MIN ' , &
                                                           '1HOUR ' , &
                                                           '2HOUR ' , &
                                                           '3HOUR ' , &
                                                           '4HOUR ' , &
                                                           '6HOUR ' , &
                                                           '8HOUR ' , &
                                                           '12HOUR' , &
                                                           '1DAY  ' , &
                                                           '1WEEK ' , &
                                                           '1MON  ' , &
                                                           '1YEAR ' ]

  ! -------------------------------------------------------------
  ! --- OVERLOADED METHODS
  ! -------------------------------------------------------------

  !Overload methods for computing number of periods between two times or time stamps
  INTERFACE NPeriods
    MODULE PROCEDURE NPeriodsBetweenTimeStamps
    MODULE PROCEDURE NPeriodsBetweenTimes
  END INTERFACE

  !Define .LE. operator for time unit comparison
  INTERFACE OPERATOR(.TULE.)
    MODULE PROCEDURE TimeUnit_CheckForLessThanOrEqualTo
  END INTERFACE

  !Define .LT. operator for time stamp comparison
  INTERFACE OPERATOR(.TSLT.)
    MODULE PROCEDURE CheckForLessThan
  END INTERFACE

  !Define .GT. operator for time stamp comparison
  INTERFACE OPERATOR(.TSGT.)
    MODULE PROCEDURE CheckForGreaterThan
  END INTERFACE

  !Define .GE. operator for time stamp comparison
  INTERFACE OPERATOR(.TSGE.)
    MODULE PROCEDURE CheckForGreaterThanOrEqualTo
  END INTERFACE

  !Conversion to DSS-style date
  INTERFACE DSSStyleDate
    MODULE PROCEDURE DSSStyleDate_FromTimeStamp
    MODULE PROCEDURE DSSStyleDate_FromDayMonthYear
  END INTERFACE

CONTAINS

!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!                     METHODS FOR TIME STAMP MANIPULATIONS
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CHECK IF A TIEM INTERVAL IS RECOGNIZED
  ! -------------------------------------------------------------
  FUNCTION IsTimeIntervalValid(cInterval) RESULT(iIndex)
    CHARACTER(LEN=*),INTENT(IN) :: cInterval
    INTEGER                     :: iIndex

    !Do we have the cInterval in the recgnized interals list?
    DO iIndex=1,SIZE(RecognizedIntervals)
        IF (TRIM(UpperCase(ADJUSTL(cInterval))) .EQ. TRIM(RecognizedIntervals(iIndex))) EXIT
    END DO

    IF (iIndex .GT. SIZE(RecognizedIntervals)) iIndex = 0

  END FUNCTION IsTimeIntervalValid

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CHECK IF A YEAR IS LEAP YEAR
  ! -------------------------------------------------------------
  FUNCTION IsLeapYear(iYear) RESULT(lLeapYear)
    INTEGER,INTENT(IN) :: iYear
    LOGICAL            :: lLeapYear

    IF (MODULO(iYear,400) .EQ. 0) THEN
      lLeapYear = .TRUE.
    ELSE IF (MODULO(iYear,100) .EQ. 0) THEN
      lLeapYear = .FALSE.
    ELSE IF (MODULO(iYear,4) .EQ. 0) THEN
      lLeapYear = .TRUE.
    ELSE
      lLeapYear = .FALSE.
    END IF

  END FUNCTION IsLeapYear

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CONVERT  JULIAN DAY TO DAY, MONTH, YEAR
  ! -------------------------------------------------------------
  SUBROUTINE JulianDateToDayMonthYear(iJulian,iDay,iMonth,iYear,iStat)
    INTEGER,INTENT(IN)           :: iJulian
    INTEGER,INTENT(OUT)          :: iDay,iMonth,iYear
    INTEGER,OPTIONAL,INTENT(OUT) :: iStat

    !Local variables
    INTEGER :: L,N

    L      = iJulian+68569
    N      = 4*L/146097
    L      = L-(146097*N+3)/4
    iYear  = 4000*(L+1)/1461001
    L      = L-1461*iYear/4+31
    iMonth = 80*L/2447
    iDay   = L-2447*iMonth/80
    L      = iMonth/11
    iMonth = iMonth+2-12*L
    iYear  = 100*(N-49)+iYear+L

    IF (PRESENT(iStat)) iStat = 0

  END SUBROUTINE JulianDateToDayMonthYear

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CONVERT DAY, MONTH, YEAR TO JULIAN DAY STARTING FROM 1 Jan 0001
  ! -------------------------------------------------------------
  SUBROUTINE DayMonthYearToJulianDate(iDay,iMonth,iYear,iJulian,iStat)
    INTEGER,INTENT(IN)           :: iDay,iMonth,iYear
    INTEGER,INTENT(OUT)          :: iJulian
    INTEGER,OPTIONAL,INTENT(OUT) :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+24) :: ThisProcedure = ModName // 'DayMonthYearToJulianDate'
    INTEGER                      :: ErrorCode

    !Initialize
    IF (PRESENT(iStat)) iStat = 0

    !Make sure iYear is not less than 1
    IF (iYear .LT. 1) THEN
      IF (PRESENT(iStat)) THEN
        iStat = 1
        RETURN
      ELSE
        CALL LogMessage('Cannot convert dates with calendar year less than 1 to Julian day!',iFatal,ThisProcedure)
      END IF
    END IF

    !Make sure iMonth is between 1 and 12
    IF (iMonth.LT.1  .OR.  iMonth.GT.12) THEN
      IF (PRESENT(iStat)) THEN
        iStat = 1
        RETURN
      ELSE
        CALL LogMessage('Incorrect number for month ('//TRIM(IntToText(iMonth))//')!',iFatal,ThisProcedure)
      END IF
    END IF

    !Make sure day is correct
    ErrorCode = 0
    SELECT CASE (iMonth)
      CASE (1,3,5,7,8,10,12)
        IF (iDay.LT.1 .OR. iDay.GT.31) ErrorCode = 1

      CASE (4,6,9,11)
        IF (iDay.LT.1 .OR. iDay.GT.30) ErrorCode = 1

      CASE (2)
        IF (IsLeapYear(iYear)) THEN
          IF (iDay.LT.1 .OR. iDay.GT.29) ErrorCode = 1
        ELSE
          IF (iDay.LT.1 .OR. iDay.GT.28) ErrorCode = 1
        END IF

    END SELECT
    IF (ErrorCode .NE. 0) THEN
      IF (PRESENT(iStat)) THEN
        iStat = 1
        RETURN
      ELSE
        CALL LogMessage('Day ('//TRIM(IntToText(iDay))//') of the month is incorrect given the month ('//TRIM(IntToText(iMonth))//')!',iFatal,ThisProcedure)
      END IF
    END IF

    !Convert
    iJulian = iDay-32075+1461*(iYear+4800+(iMonth-14)/12)/4+367*(iMonth-2-(iMonth-14)/12*12)/12-3*((iYear+4900+(iMonth-14)/12)/100)/4

  END SUBROUTINE DayMonthYearToJulianDate

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CORRECT A TIME STAMP FOR LEAP YEAR
  ! -------------------------------------------------------------
  FUNCTION LeapYearCorrection(TimeStampIn) RESULT(TimeStampOut)
    CHARACTER(LEN=TimeStampLength),INTENT(IN)::TimeStampIn
    CHARACTER(LEN=TimeStampLength)::TimeStampOut

    !Local variables
    CHARACTER(LEN=ModNameLen+18) :: ThisProcedure = ModName // 'LeapYearCorrection'
    INTEGER                      :: iYear

    !Initialize
    TimeStampOut = TimeStampIn

    !Check if time stamp refers to February 29
    IF (ExtractMonth(TimeStampIn) .NE. 2) RETURN
    IF (ExtractDay(TimeStampIn) .NE. 29) RETURN

    !Get the year
    iYear = ExtractYear(TimeStampIn)

    !Make sure that year of time stamp is not the Year 4000 flag
    IF (iYear .EQ. 4000) THEN
      MessageArray(1)='Time stamp '//TimeStampIn//' cannot be corrected for '
      MessageArray(2)='leap year because it includes Year 4000 flag!'
      CALL LogMessage(MessageArray(1:2),iFatal,ThisProcedure)
    END IF

    !Correct February 29 if it is a leap year
    IF (.NOT. IsLeapYear(iYear)) TimeStampOut(4:5) = '28'

  END FUNCTION LeapYearCorrection

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CHECK IF THE TIME-STAMP OF A DATA IS VALID
  ! -------------------------------------------------------------
  FUNCTION IsTimeStampValid(ALine) RESULT (TimeStampValidity)
    CHARACTER(LEN=*),INTENT(IN)::ALine
    LOGICAL::TimeStampValidity

    !Local variables
    CHARACTER(LEN=1),PARAMETER::Slash='/',Colon=':',Underscore='_'
    CHARACTER(LEN=TimeStampLength)::TimeStamp

    !Initialize
    TimeStamp         = StripTimeStamp(ALine)
    TimeStampValidity = .FALSE.      !Default value

    !Check if possible time stamp includes two of "/"
    IF (CountOccurance(Slash,TimeStamp).NE.2) RETURN

    !Check if possible time stamp includes one of "_"
    IF (CountOccurance(Underscore,TimeStamp).NE.1) RETURN

    !Check if possible time stamp includes one of ":"
    IF (CountOccurance(Colon,TimeStamp).LT.1) RETURN

    !Check time stamp has the right number of characaters
    IF (LEN_TRIM(ADJUSTL(TimeStamp)) .NE. TimeStampLength) RETURN

    !If made it all the way here, the time stamp is valid
    TimeStampValidity=.TRUE.

  END FUNCTION IsTimeStampValid

  ! -------------------------------------------------------------
  ! --- FUNCTION TO STRIP TIME STAMP FROM A STRING
  ! -------------------------------------------------------------
  FUNCTION StripTimeStamp(ALine,Location) RESULT(TimeStamp)
    CHARACTER(LEN=*),INTENT(IN)::ALine
    INTEGER,OPTIONAL::Location
    CHARACTER(LEN=TimeStampLength)::TimeStamp

    !Local variables
    !^^^^^^^^^^^^^^^
    CHARACTER(LEN=1),PARAMETER::Slash='/'
    INTEGER::LocationOfFirstSlash,TimeStampBegin,TimeStampEnd

    TimeStamp='' !Default
    IF (PRESENT(Location)) Location=0 !Default

    !Check if the line includes "/"
    !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    LocationOfFirstSlash=FirstLocation(Slash,ALine)
    IF (LocationOfFirstSlash.EQ.0) RETURN  !No slashes found; therefore the data is not time stamped

    !Isolate the possible time stamp from the line
    !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    TimeStampBegin = LocationOfFirstSlash-2                ;  TimeStampBegin = MAX(TimeStampBegin , 1)
    TimeStampEnd   = TimeStampBegin + TimeStampLength - 1  ;  TimeStampEnd   = MAX(TimeStampEnd , TimeStampBegin)
    TimeStamp      = ALine(TimeStampBegin:TimeStampEnd)

    IF (PRESENT(Location)) Location=TimeStampBegin

  END FUNCTION StripTimeStamp

  ! -------------------------------------------------------------
  ! --- FUNCTION TO EXTRACT MONTH FROM TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION ExtractMonth(TimeStamp) RESULT(Month)
    CHARACTER(LEN=TimeStampLength)::TimeStamp
    INTEGER::Month

    Month=TextToInt(TimeStamp(1:2))

  END FUNCTION ExtractMonth

  ! -------------------------------------------------------------
  ! --- FUNCTION TO EXTRACT DAY FROM TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION ExtractDay(TimeStamp) RESULT(Day)
    CHARACTER(LEN=TimeStampLength)::TimeStamp
    INTEGER::Day

    Day=TextToInt(TimeStamp(4:5))

  END FUNCTION ExtractDay

  ! -------------------------------------------------------------
  ! --- FUNCTION TO EXTRACT YEAR FROM TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION ExtractYear(TimeStamp) RESULT(Year)
    CHARACTER(LEN=TimeStampLength)::TimeStamp
    INTEGER::Year

    Year=TextToInt(TimeStamp(7:10))

  END FUNCTION ExtractYear

  ! -------------------------------------------------------------
  ! --- FUNCTION TO EXTRACT HOUR FROM TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION ExtractHour(TimeStamp) RESULT(Hour)
    CHARACTER(LEN=TimeStampLength)::TimeStamp
    INTEGER::Hour

    Hour=TextToInt(TimeStamp(12:13))

  END FUNCTION ExtractHour

  ! -------------------------------------------------------------
  ! --- FUNCTION TO EXTRACT MINUTE FROM TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION ExtractMinute(TimeStamp) RESULT(Minute)
    CHARACTER(LEN=TimeStampLength)::TimeStamp
    INTEGER::Minute

    Minute=TextToInt(TimeStamp(15:16))

  END FUNCTION ExtractMinute

  ! -------------------------------------------------------------
  ! --- SUBROUTINE TO EXTRACT JULIAN DATE AND MINUTES PAST THE MIDNIGHT FROM TIME STAMP
  ! -------------------------------------------------------------
  SUBROUTINE TimeStampToJulianDateAndMinutes(TimeStamp,JulianDate,MinutesAfterMidnight,STAT)
    CHARACTER(LEN=TimeStampLength),INTENT(IN) :: TimeStamp
    INTEGER,INTENT(OUT)                       :: JulianDate,MinutesAfterMidnight
    INTEGER,OPTIONAL                          :: STAT

    !Local variables
    CHARACTER(LEN=ModNameLen+31) :: ThisProcedure = ModName // 'TimeStampToJulianDateAndMinutes'
    INTEGER                      :: ErrorCode

    !Convert date to Julian date
    CALL DayMonthYearToJulianDate(ExtractDay(TimeStamp),ExtractMonth(TimeStamp),ExtractYear(TimeStamp),JulianDate,ErrorCode)

    !Handle error code
    IF (PRESENT(STAT)) THEN
      STAT=ErrorCode
    ELSE
      IF (ErrorCode.NE.0) CALL LogMessage('Error in converting simulation date to Julian date',3,ThisProcedure)
    END IF

    !Compute minutes past midnight in the day specified in the time stamp
    MinutesAfterMidnight=ExtractHour(TimeStamp)*60+ExtractMinute(TimeStamp)

  END SUBROUTINE TimeStampToJulianDateAndMinutes

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CONVERT DAY,MONTH, YEAR TO DSS STYLE DATE
  ! -------------------------------------------------------------
  FUNCTION DSSStyleDate_FromDayMonthYear(iDay,iMon,iYear) RESULT(Date)
    INTEGER,INTENT(IN) :: iDay,iMon,iYear
    CHARACTER(LEN=11)  :: Date

    !Local variables
    CHARACTER(LEN=3),DIMENSION(12),PARAMETER::Months=(/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'/)

    Date = ''
    IF (iDay .LT. 10) THEN
      Date = '0'//TRIM(IntToText(iDay))//TRIM(Months(iMon))//TRIM(IntToText(iYear))
    ELSE
      Date = TRIM(IntToText(iDay))//TRIM(Months(iMon))//TRIM(IntToText(iYear))
    END IF

  END FUNCTION DSSStyleDate_FromDayMonthYear

  ! -------------------------------------------------------------
  ! --- FUNCTION TO EXTRACT DSS STYLE DATE FROM TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION DSSStyleDate_FromTimeStamp(TimeStamp) RESULT(Date)
    CHARACTER(LEN=TimeStampLength),INTENT(IN) :: TimeStamp
    CHARACTER(LEN=11)                         :: Date

    !Local variables
    !^^^^^^^^^^^^^^^
    CHARACTER(LEN=3),DIMENSION(12),PARAMETER::Months=(/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'/)
    INTEGER::Day,Month,Year

    Day=ExtractDay(TimeStamp)
    Month=ExtractMonth(TimeStamp)
    Year=ExtractYear(TimeStamp)
    Date=TRIM(IntToText(Day))//' '//TRIM(Months(Month))//' '//TRIM(IntToText(Year))

  END FUNCTION DSSStyleDate_FromTimeStamp

  ! -------------------------------------------------------------
  ! --- FUNCTION TO EXTRACT DSS STYLE HOURS AFTER MIDNIGHT FROM TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION DSSStyleHoursAfterMidnight(TimeStamp) RESULT(HoursAfterMidnight)
    CHARACTER(LEN=TimeStampLength),INTENT(IN)::TimeStamp
    CHARACTER(LEN=4)::HoursAfterMidnight

    !Generate HoursAfterMidnight
    HoursAfterMidnight=TimeStamp(12:13)//TimeStamp(15:16)

  END FUNCTION DSSStyleHoursAfterMidnight

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CONVERT JULIAN DATE AND MINUTES AFTER MIDNIGHT TO TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION JulianDateAndMinutesToTimeStamp(JulianDate,MinutesAfterMidnight) RESULT(TimeStamp)
    INTEGER,INTENT(IN)::JulianDate,MinutesAfterMidnight
    CHARACTER(LEN=TimeStampLength)::TimeStamp

    !Local variables
    !^^^^^^^^^^^^^^^
    INTEGER :: Day,Month,Year,Minute,Hour,TempJulianDate

    !Initialize
    !^^^^^^^^^^
    TimeStamp='00/00/0000_00:00'

    !Find number of hours
    !^^^^^^^^^^^^^^^^^^^^
    Hour=MinutesAfterMidnight/60
    IF (Hour.GT.0) THEN
      IF (Hour.LT.10) THEN
        TimeStamp(13:13)=TRIM(IntToText(Hour))
      ELSE
        TimeStamp(12:13)=TRIM(IntTotext(Hour))
      END IF
    END IF

    !Find number of minutes
    !^^^^^^^^^^^^^^^^^^^^^^
    Minute=MinutesAfterMidnight-Hour*60
    IF (Minute.GT.0) THEN
      IF (Minute.LT.10) THEN
        TimeStamp(16:16)=TRIM(IntToText(Minute))
      ELSE
        TimeStamp(15:16)=TRIM(IntTotext(Minute))
      END IF
    END IF

    !Check for midnight
    !^^^^^^^^^^^^^^^^^^
    TempJulianDate=JulianDate
    IF (Hour.EQ.0 .AND. Minute.EQ.0) THEN
      TimeStamp(12:13)='24'
      TempJulianDate=JulianDate-1
    END IF

    !Convert Julian day to day, month, year
    !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    CALL JulianDateToDayMonthYear(TempJulianDate,Day,Month,Year)
    IF (Month.LT.10) THEN
      TimeStamp(2:2)=TRIM(IntToText(Month))
    ELSE
      TimeStamp(1:2)=TRIM(IntTotext(Month))
    END IF
    IF (Day.LT.10) THEN
      TimeStamp(5:5)=TRIM(IntToText(Day))
    ELSE
      TimeStamp(4:5)=TRIM(IntTotext(Day))
    END IF
    TimeStamp(7:10)=Trim(IntToText(Year))

  END FUNCTION JulianDateAndMinutesToTimeStamp

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CONVERT TIME STAMP TO FRACTIONAL JULIAN TIME
  ! -------------------------------------------------------------
  FUNCTION TimeStampToJulian(TimeStamp,STAT) RESULT(Julian)
    CHARACTER(LEN=TimeStampLength),INTENT(IN)::TimeStamp
    INTEGER,OPTIONAL::STAT
    REAL(8)::Julian

    !Local variables
    INTEGER::JulianDate,Minutes,LocalStat

    !Convert time stamp to Julian date and minutes after midnight
    CALL TimeStampToJulianDateAndMinutes(TimeStamp,JulianDate,Minutes,STAT=LocalStat)

    !Compute fractiona Julian time
    Julian=REAL(JulianDate,8)+REAL(Minutes,8)/1440d0

    !Take care of returned error code
    IF (PRESENT(STAT))  STAT=LocalStat

  END FUNCTION TimeStampToJulian

  ! -------------------------------------------------------------
  ! --- FUNCTION TO CONVERT FRACTIONAL JULIAN TIME TO TIME STAMP
  ! -------------------------------------------------------------
  FUNCTION JulianToTimeStamp(Julian) RESULT(TimeStamp)
    REAL(8),INTENT(IN)             :: Julian
    CHARACTER(LEN=TimeStampLength) :: TimeStamp

    !Local variables
    INTEGER::JulianDate,MinutesAfterMidnight

    !Get the integer date part of the fractional Julian date
    JulianDate = INT(Julian)

    !Get the minutes after midnight
    MinutesAfterMidnight = INT(1440d0 * (Julian - REAL(JulianDate,8)))

    TimeStamp = JulianDateAndMinutesToTimeStamp(JulianDate,MinutesAfterMidnight)

  END FUNCTION JulianToTimeStamp

  ! -------------------------------------------------------------
  ! --- GETE A LIST OF JULIAN DATES BETWEEN TWO TIME STAMPS USING A TIME INCREMENT
  ! -------------------------------------------------------------
  SUBROUTINE GetJulianDatesBetweenTimeStampsWithTimeIncrement(Interval_InMinutes,cBeginDateAndTime,cEndDateAndTime,rJulianDates)
    INTEGER,INTENT(IN)          :: Interval_InMinutes
    CHARACTER(LEN=*),INTENT(IN) :: cBeginDateAndTime,cEndDateAndTime
    REAL(8),INTENT(OUT)         :: rJulianDates(:)

    !Local variables
    INTEGER                        :: indx,ErrorCode
    CHARACTER(LEN=TimeStampLength) :: cTimeStamp

    cTimeStamp = cBeginDateAndTime
    DO indx=1,SIZE(rJulianDates)
        rJulianDates(indx) = TimeStampToJulian(cTimeStamp,ErrorCode)
        cTimeStamp         = IncrementTimeStamp(cTimeStamp,Interval_InMinutes,1)
        IF (cTimeStamp .TSGT. cEndDateAndTime) THEN
            rJulianDates(indx+1:) = 0.0
            EXIT
        END IF
    END DO

  END SUBROUTINE GetJulianDatesBetweenTimeStampsWithTimeIncrement

  ! -------------------------------------------------------------
  ! --- SUBROUTINE TO ADJUST THE YEAR 4000 FLAG WITH THE YEAR OF ANOTHER TIME STAMP
  ! -------------------------------------------------------------
  SUBROUTINE AdjustTimeStampWithYear4000(AdjustedTimeStamp,TimeStamp,Year4000Flag)
    CHARACTER(LEN=TimeStampLength)::AdjustedTimeStamp
    CHARACTER(LEN=TimeStampLength),INTENT(IN)::TimeStamp
    LOGICAL,INTENT(OUT)::Year4000Flag

    !Local variables
    INTEGER::Year
    !Default
    Year4000Flag=.FALSE.

    !If year in AdjustedTimeStamp is 4000, replace it with the year in TimeStamp
    IF (ExtractYear(AdjustedTimeStamp).EQ.4000) THEN
      Year4000Flag=.TRUE.
      !Extract year from TimeStamp
      Year=ExtractYear(TimeStamp)
      !Replace Year4000 flag in AdjustedTimeStamp by year from TimeStamp
      AdjustedTimeStamp(7:10)=TRIM(IntToText(Year))
    END IF

  END SUBROUTINE AdjustTimeStampWithYear4000

  ! -------------------------------------------------------------
  ! --- SUBROUTINE TO CONVERT TIME STAMP TO TIME STAMP WITH YEAR 4000 FLAG
  ! -------------------------------------------------------------
  FUNCTION TimeStampToYear4000(TimeStamp) RESULT(ConvertedTimeStamp)
    CHARACTER(LEN=TimeStampLength),INTENT(IN)::TimeStamp
    CHARACTER(LEN=TimeStampLength)::ConvertedTimeStamp

    ConvertedTimeStamp=TimeStamp
    ConvertedTimeStamp(7:10)=TRIM(IntToText(4000))

  END FUNCTION TimeStampToYear4000

  ! -------------------------------------------------------------
  ! --- FUNCTION TO INCREMENT A TIME STAMP BY A CERTAIN NUMBER OF MINUTES
  ! -------------------------------------------------------------
  FUNCTION IncrementTimeStamp(TimeStamp,Interval_InMinutes,NumberOfIntervals) RESULT(IncrementedTimeStamp)
    CHARACTER(LEN=*),INTENT(IN)    :: TimeStamp
    INTEGER,INTENT(IN)             :: Interval_InMinutes
    INTEGER,INTENT(IN),OPTIONAL    :: NumberOfIntervals
    CHARACTER(LEN=TimeStampLength) :: IncrementedTimeStamp

    !Local variables
    INTEGER :: Sign,LocalMinutes,JulianDate,MinutesAfterMidnight,EndJulianDate,EndMinutesAfterMidnight,LocalNumberOfIntervals

    !Initialize
    LocalNumberOfIntervals=1  ;  IF (PRESENT(NumberOfIntervals)) LocalNumberOfIntervals=NumberOfIntervals

    !Convert TimeStamp to integer JulianDate and MinutesAfterMidnight
    CALL TimeStampToJulianDateAndMinutes(TimeStamp,JulianDate,MinutesAfterMidnight)

    !Increment Julian date and minutes past the midnight
    Sign=1
    LocalMinutes=Interval_InMinutes
    IF (Interval_InMinutes.LT.0) THEN
      Sign=-1
      LocalMinutes=ABS(Interval_InMinutes)
    END IF
    CALL IncrementJulianDateAndMinutesAfterMidnight(LocalMinutes,Sign*LocalNumberOfIntervals,JulianDate,MinutesAfterMidnight,EndJulianDate,EndMinutesAfterMidnight)
    JulianDate           = EndJulianDate
    MinutesAfterMidnight = EndMinutesAfterMidnight

    !Convert integer JulianDate and MinutesAfterMidnight to TimeStamp
    IncrementedTimeStamp=JulianDateAndMinutesToTimeStamp(JulianDate,MinutesAfterMidnight)

  END FUNCTION IncrementTimeStamp

  ! -------------------------------------------------------------
  ! --- SUBROUTINE TO INCREMENT A JULIAN DATE AND MINUTES-AFTER-MIDNIGHT BY A CERTAIN NUMBER OF MINUTES
  ! -------------------------------------------------------------
  SUBROUTINE IncrementJulianDateAndMinutesAfterMidnight(Interval_InMinutes,NumberOfIntervals,iBeginJulianDate,iBeginMinutesAfterMidnight,iEndJulianDate,iEndMinutesAfterMidnight)
    INTEGER,INTENT(IN)  :: Interval_InMinutes,NumberOfIntervals,iBeginJulianDate,iBeginMinutesAfterMidnight
    INTEGER,INTENT(OUT) :: iEndJulianDate,iEndMinutesAfterMidnight

    !Local variables
    INTEGER           :: NDays,NMinutes,AllMinutes,iDay,iMonth,iYear,NYears,NMonths
    LOGICAL           :: lLastDay
    INTEGER,PARAMETER :: DaysInMonth(12) = (/31,29,31,30,31,30,31,31,30,31,30,31/)

    !Initialize
    iEndJulianDate           = iBeginJulianDate
    iEndMinutesAfterMidnight = iBeginMinutesAfterMidnight

    !Increment
    SELECT CASE (Interval_InMinutes)
      !Interval is less than or equal to a week
      CASE (:10080)
        !Amount of minutes to increment
        AllMinutes = Interval_InMinutes * NumberOfIntervals

        !Number of days
        NDays = AllMinutes / 1440

        !Number of minutes
        NMinutes = AllMinutes - (NDays * 1440)

        !Incremented values
        iEndJulianDate           = iBeginJulianDate + NDays
        iEndMinutesAfterMidnight = iBeginMinutesAfterMidnight + NMinutes

        !Make sure MinutesAfterMidnight is okay
        IF (iEndMinutesAfterMidnight .GT. 1440) THEN
          iEndJulianDate           = iEndJulianDate + 1
          iEndMinutesAfterMidnight = iEndMinutesAfterMidnight - 1440
        ELSEIF (iEndMinutesAfterMidnight .LT. 1) THEN
          iEndJulianDate           = iEndJulianDate - 1
          iEndMinutesAfterMidnight = 1440 + iEndMinutesAfterMidnight
        END IF

      !Interval is month or year
      CASE (40320:)
        !Find day, month, year of beginning Julian date
        CALL JulianDateToDayMonthYear(iBeginJulianDate,iDay,iMonth,iYear)

        !Are we at the last day of month?
        lLastDay = .FALSE.
        SELECT CASE (iMonth)
          CASE (1,3,5,7,8,10,12)
            IF (iDay .EQ. 31) lLastDay = .TRUE.
          CASE (4,6,9,11)
            IF (iDay .EQ. 30) lLastDay = .TRUE.
          CASE (2)
            IF (IsLeapYear(iYear)) THEN
              IF (iDay .EQ. 29) lLastDay = .TRUE.
            ELSE
              IF (iDay .EQ. 28) lLastDay = .TRUE.
            END IF
        END SELECT

        !Find number of years and months to increment
        IF (Interval_InMinutes.GE.40320  .AND.  Interval_InMinutes.LE.44640) THEN
          NYears  = NumberOfIntervals / 12
          NMonths = NumberOfIntervals - NYears*12
        ELSE
          NYears  = NumberOfIntervals
          NMonths = 0
        END IF

        !Now, increment
        iYear  = iYear + NYears
        iMonth = iMonth + NMonths

        !Make sure month is okay
        IF (iMonth .GT. 12) THEN
          iYear  = iYear + 1
          iMonth = iMonth - 12
        ELSEIF (iMonth .LT. 1) THEN
          iYear  = iYear - 1
          iMonth = 12 + iMonth
        END IF

        !Set the day properly
        IF (lLastDay) THEN
          IF (iBeginMinutesAfterMidnight .EQ. 1440) THEN
            IF (iMonth .EQ. 2) THEN
              IF (IsLeapYear(iYear)) THEN
                iDay = 29
              ELSE
                iDay = 28
              END IF
            ELSE
              iDay = DaysInMonth(iMonth)
            END IF
          END IF
        END IF

        !If incremented month is 2, make sure that day is not greater than 28 or 29
        IF (iMonth .EQ. 2) THEN
          IF (iDay .GT. 28) THEN
            IF (IsLeapYear(iYear)) THEN
              iDay = 29
            ELSE
              iDay = 28
            END IF
          END IF
        END IF

        !Now compute ending Julian Date
        CALL DayMonthYearToJulianDate(iDay,iMonth,iYear,iEndJulianDate)
        iEndMinutesAfterMidnight = iBeginMinutesAfterMidnight

    END SELECT

  END SUBROUTINE IncrementJulianDateAndMinutesAfterMidnight

!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!                     METHODS FOR TIME SERIES DATA
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////

  ! -------------------------------------------------------------
  ! --- SET SIMULATION TIME STEP LENGTH
  ! -------------------------------------------------------------
  SUBROUTINE SetSimulationTimeStep(DELTAT_InMinutes)
    INTEGER,INTENT(IN)::DELTAT_InMinutes

    SimulationTimeStep_InMinutes=DELTAT_InMinutes

  END SUBROUTINE SetSimulationTimeStep

  ! -------------------------------------------------------------
  ! --- SET THE CACHE SIZE FOR THE TIME SERIES DATA OUTPUT
  ! -------------------------------------------------------------
  SUBROUTINE SetCacheLimit(Cache)
    INTEGER,INTENT(IN)::Cache

    CacheLimit=Cache

  END SUBROUTINE SetCacheLimit

  ! -------------------------------------------------------------
  ! --- GET THE CACHE SIZE FOR THE TIME SERIES DATA OUTPUT
  ! -------------------------------------------------------------
  FUNCTION GetCacheLimit() RESULT(iCache)
    INTEGER :: iCache

    iCache = CacheLimit

  END FUNCTION GetCacheLimit

  ! -------------------------------------------------------------
  ! --- SET THE NumberOfDataBatch, NumberOfDataRows AND NumberOfDataColumns FOR STORAGE OF TIME SERIES DATA BEFORE PRINT-OUT
  ! -------------------------------------------------------------
  SUBROUTINE SetTSDCacheSize(FileName            , &
                             ValuesForOutput     , &
                             NumberOfDataBatch   , &
                             NumberOfDataRows    , &
                             NumberOfDataColumns , &
                             NColumnsOfData      , &
                             NRowsOfData         , &
                             TimeArray           )
    CHARACTER(LEN=*),INTENT(IN)           :: FileName
    REAL(8),ALLOCATABLE                   :: ValuesForOutput(:,:,:)
    INTEGER,INTENT(OUT)                   :: NumberOfDataBatch,NumberOfDataRows,NumberOfDataColumns
    INTEGER,INTENT(IN)                    :: NColumnsOfData
    INTEGER,OPTIONAL,INTENT(IN)           :: NRowsOfData
    CHARACTER(LEN=*),OPTIONAL,ALLOCATABLE :: TimeArray(:)

    !Local variables
    CHARACTER(LEN=ModNAmeLen+15) :: ThisProcedure = ModName // 'SetTSDCacheSize'
    INTEGER                      :: nbatch,nrow,ncolumn,ErrorCode

    !Set nrow
    nrow=1  !Default
    IF (PRESENT(NRowsOfData)) nrow=NRowsOfData

    !Identify the size of storage array
    ncolumn=NColumnsOfData
    IF (nrow*ncolumn.GT.CacheLimit) THEN
      nbatch=1
    ELSE
      nbatch=CacheLimit/(nrow*ncolumn)
    END IF

    !Check if the storage arrays are already defined
    IF (ALLOCATED(ValuesForOutput)) THEN
      DEALLOCATE(ValuesForOutput)
      IF (PRESENT(TimeArray)) DEALLOCATE (TimeArray)
    END IF

    !Allocate memory for the data storage array
    ALLOCATE (ValuesForOutput(nrow,ncolumn,nbatch),STAT=ErrorCode)
    IF (ErrorCode.NE.0) CALL LogMessage('Error in allocating data storage array for file '//TRIM(FileName),iFatal,ThisProcedure)

    !Allocate memory for the time storage array
    IF (PRESENT(TimeArray)) THEN
      ALLOCATE (TimeArray(nbatch),STAT=ErrorCode)
      IF (ErrorCode.NE.0) CALL LogMessage('Error in allocating time storage array for file '//TRIM(FileName),iFatal,ThisProcedure)
    END IF

    !Set the data fields
    NumberOfDataBatch=nbatch
    NumberOfDataRows=nrow
    NumberOfDataColumns=ncolumn

  END SUBROUTINE SetTSDCacheSize

  ! -------------------------------------------------------------
  ! --- MODIFY THE TIME SERIES RATE TYPE INPUT DATA SO THAT ITS TIME UNIT IS CONSISTENT WITH SIMULATION TIME STEP
  ! -------------------------------------------------------------
  SUBROUTINE AdjustRateTypeData(r,RateTypeDataArray,ConversionFactor,DataInterval,LastDataDate)
    REAL(8),DIMENSION(:,:)::r
    LOGICAL,DIMENSION(:),INTENT(IN)::RateTypeDataArray
    REAL(8),OPTIONAL,INTENT(IN)::ConversionFactor                    !In this case the conversion factor is supplied directly
    INTEGER,OPTIONAL,INTENT(IN)::DataInterval                        !In this case the time step length in minutes and
    CHARACTER(LEN=TimeStampLength),OPTIONAL,INTENT(IN)::LastDataDate ! the date of last data read are supplied as character

    !Local variables
    INTEGER::nrow,ncol
    REAL(8)::r1d(SIZE(r,DIM=1)*SIZE(r,DIM=2))
    REAL(8)::Factor
    CHARACTER(LEN=TimeStampLength)::TimeStampBegin

    !Initialize
    nrow=SIZE(r,DIM=1)
    ncol=SIZE(r,DIM=2)

    !Calculate conversion factor if necessary
    IF (PRESENT(ConversionFactor)) THEN        !Conversion factor is supplied directly
      Factor=ConversionFactor
    ELSEIF (PRESENT(DataInterval) .AND. PRESENT(LastDataDate)) THEN !Time step length and the date of last data read are supplied
      IF (DataInterval.EQ.0) THEN
        Factor=1d0
      ELSE
        !Decrement the time stamp of the data last read by the interval minutes
        TimeStampBegin=IncrementTimeStamp(LastDataDate,-DataInterval)
        !Compute Factor
        Factor=REAL(NPeriods(SimulationTimeStep_InMinutes,TimeStampBegin,LastDataDate),8)
      END IF
    END IF

    !Convert
    SELECT CASE (SIZE(RateTypeDataArray))
      CASE (1)
        IF (RateTypeDataArray(1)) r(:,:)=r(:,:)/Factor

      CASE DEFAULT
        r1d=PACK(TRANSPOSE(r),MASK=.TRUE.)
        WHERE (RateTypeDataArray) r1d=r1d/Factor
        r=RESHAPE(r1d,(/nrow,ncol/),ORDER=(/2,1/))

    END SELECT

  END SUBROUTINE AdjustRateTypeData

!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!                  MISCELLENEOUS METHODS FOR TIME RELATED DATA
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////
!////////////////////////////////////////////////////////////////////////////////

  ! -------------------------------------------------------------
  ! --- FUNCTION TO TEST LESS THAN (.LE.) COMPARISON B/W TWO TIME UNITS
  ! -------------------------------------------------------------
  FUNCTION TimeUnit_CheckForLessThanOrEqualTo(TimeUnit1,TimeUnit2) RESULT(lResult)
    CHARACTER(LEN=*),INTENT(IN) :: TimeUnit1,TimeUnit2
    LOGICAL                     :: lResult

    !Local variables
    INTEGER :: TimeUnit1_InMinutes,TimeUnit2_InMinutes
    REAL(8) :: rDummy

    !Convert to minutes
    CALL CTimeStep_To_RTimeStep(TimeUnit1,rDummy,TimeUnit1_InMinutes)
    CALL CTimeStep_To_RTimeStep(TimeUnit2,rDummy,TimeUnit2_InMinutes)

    !Compare
    IF (TimeUnit1_InMinutes .LE. TimeUnit2_InMinutes) THEN
        lResult = .TRUE.
    ELSE
        lResult = .FALSE.
    END IF

  END FUNCTION TimeUnit_CheckForLessThanOrEqualTo

  ! -------------------------------------------------------------
  ! --- FUNCTION TO TEST LESS THAN (.LT.) COMPARISON B/W TWO TIME STAMPS
  ! -------------------------------------------------------------
  FUNCTION CheckForLessThan(TimeStamp1,TimeStamp2) RESULT(TestResult)
    CHARACTER(LEN=TimeStampLength),INTENT(IN)::TimeStamp1,TimeStamp2
    LOGICAL::TestResult

    !Local variables
    INTEGER::JulianDate1,MinutesAfterMidnight1,JulianDate2,MinutesAfterMidnight2

    !Initialize
    TestResult=.FALSE.

    !Convert time stamps to equivalent Julain dates and minutes
    CALL TimeStampToJulianDateAndMinutes(TimeStamp1,JulianDate1,MinutesAfterMidnight1)
    CALL TimeStampToJulianDateAndMinutes(TimeStamp2,JulianDate2,MinutesAfterMidnight2)

    !Compare
    IF (JulianDate1.LT.JulianDate2) THEN
      TestResult=.TRUE.
    ELSEIF (JulianDate1.EQ.JulianDate2) THEN
      IF (MinutesAfterMidnight1.LT.MinutesAfterMidnight2) TestResult=.TRUE.
    END IF

  END FUNCTION CheckForLessThan

  ! -------------------------------------------------------------
  ! --- FUNCTION TO TEST GREATER THAN (.GT.) COMPARISON B/W TWO TIME STAMPS
  ! -------------------------------------------------------------
  FUNCTION CheckForGreaterThan(TimeStamp1,TimeStamp2) RESULT(TestResult)
    CHARACTER(LEN=TimeStampLength),INTENT(IN)::TimeStamp1,TimeStamp2
    LOGICAL::TestResult

    !Local variables
    INTEGER::JulianDate1,MinutesAfterMidnight1,JulianDate2,MinutesAfterMidnight2

    !Initialize
    TestResult=.FALSE.

    !Convert time stamps to equivalent Julain dates and minutes
    CALL TimeStampToJulianDateAndMinutes(TimeStamp1,JulianDate1,MinutesAfterMidnight1)
    CALL TimeStampToJulianDateAndMinutes(TimeStamp2,JulianDate2,MinutesAfterMidnight2)

    !Compare
    IF (JulianDate1.GT.JulianDate2) THEN
      TestResult=.TRUE.
    ELSEIF (JulianDate1.EQ.JulianDate2) THEN
      IF (MinutesAfterMidnight1.GT.MinutesAfterMidnight2) TestResult=.TRUE.
    END IF

  END FUNCTION CheckForGreaterThan

  ! -------------------------------------------------------------
  ! --- FUNCTION TO TEST GREATER THAN OR EQUAL TO (.GE.) COMPARISON B/W TWO TIME STAMPS
  ! -------------------------------------------------------------
  FUNCTION CheckForGreaterThanOrEqualTo(TimeStamp1,TimeStamp2) RESULT(TestResult)
    CHARACTER(LEN=TimeStampLength),INTENT(IN) :: TimeStamp1,TimeStamp2
    LOGICAL                                   :: TestResult

    !Local variables
    INTEGER :: JulianDate1,MinutesAfterMidnight1,JulianDate2,MinutesAfterMidnight2

    !Initialize
    TestResult = .FALSE.

    !Convert time stamps to equivalent Julain dates and minutes
    CALL TimeStampToJulianDateAndMinutes(TimeStamp1,JulianDate1,MinutesAfterMidnight1)
    CALL TimeStampToJulianDateAndMinutes(TimeStamp2,JulianDate2,MinutesAfterMidnight2)

    !Compare
    IF (JulianDate1 .GE. JulianDate2) THEN
        TestResult = .TRUE.
    END IF

  END FUNCTION CheckForGreaterThanOrEqualTo

  ! -------------------------------------------------------------
  ! --- FUNCTION TO COMPUTE THE NUMBER OF PERIODS BETWEEN TWO TIME STAMPS
  ! --- Note: Adopted from HEC-DSS library (Can Dogrul - 4/7/2011)
  ! -------------------------------------------------------------
  FUNCTION NPeriodsBetweenTimeStamps(DELTAT_InMinutes,BeginTimeStamp,EndTimeStamp) RESULT(NPeriod)
    INTEGER,INTENT(IN)          :: DELTAT_InMinutes
    CHARACTER(LEN=*),INTENT(IN) :: BeginTimeStamp,EndTimeStamp
    INTEGER                     :: NPeriod

    !Local variables
    INTEGER                        :: BeginJulianDate,EndJulianDate,BeginMinutesAfterMidnight,EndMinutesAfterMidnight, &
                                      iBeginYear,iBeginMonth,iBeginDay,iEndYear,iEndMonth,iEndDay
    CHARACTER(LEN=TimeStampLength) :: TempTimeStamp

    !Find corresponding Julian dates and minutes after midnight
    CALL TimeStampToJulianDateAndMinutes(BeginTimeStamp,BeginJulianDate,BeginMinutesAfterMidnight)
    CALL TimeStampToJulianDateAndMinutes(EndTimeStamp,EndJulianDate,EndMinutesAfterMidnight)

    !If interval is greater than or equal to a month, find corresponding day, month and year
    IF (DELTAT_InMinutes .GE. 40320) THEN
      !Find corresponding day, month, year
      CALL JulianDateToDayMonthYear(BeginJulianDate,iBeginDay,iBeginMonth,iBeginYear)
      CALL JulianDateToDayMonthYear(EndJulianDate,iEndDay,iEndMonth,iEndYear)
    END IF

    !Compute number of periods between two time stamps
    IF (DELTAT_InMinutes.GE.40320  .AND.  DELTAT_InMinutes.LE.44640) THEN
      !Monthly interval
      NPeriod       = ((iEndYear-iBeginYear) * 12) + (iEndMonth-iBeginMonth) + ((iEndDay-iBeginDay) / 27)
      TempTimeStamp = IncrementTimeStamp(BeginTimeStamp,DELTAT_InMinutes,NPeriod)
      IF (TempTimeStamp .TSGT. EndTimeStamp) NPeriod = NPeriod - 1
    ELSE IF (DELTAT_InMinutes .GE. 525600) THEN
      !Yearly interval
      NPeriod       = (iEndYear-iBeginYear) + (((iEndMonth-iBeginMonth) + (iEndDay-iBeginDay) / 28) / 12)
      TempTimeStamp = IncrementTimeStamp(BeginTimeStamp,DELTAT_InMinutes,NPeriod)
      IF (TempTimeStamp .TSGT. EndTimeStamp) NPeriod = NPeriod - 1
    ELSE
      !Otherwise
      NPeriod = (((EndJulianDate-BeginJulianDate)*1440) + (EndMinutesAfterMidnight-BeginMinutesAfterMidnight)) / DELTAT_InMinutes
    END IF

  END FUNCTION NPeriodsBetweenTimeStamps

  ! -------------------------------------------------------------
  ! --- FUNCTION TO COMPUTE THE NUMBER OF PERIODS BETWEEN TWO TIMES
  ! -------------------------------------------------------------
  FUNCTION NPeriodsBetweenTimes(DELTAT,BeginTime,EndTime) RESULT(NPeriod)
    REAL(8),INTENT(IN)::DELTAT,BeginTime,EndTime
    INTEGER::NPeriod

    !Compute number of periods between two times
    NPeriod=INT((EndTime-BeginTime)/DELTAT)

  END FUNCTION NPeriodsBetweenTimes

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

! *************************************************************
! *************************************************************
! **** TIME STEP CONVERSION METHODS
! *************************************************************
! *************************************************************

  ! -------------------------------------------------------------
  ! --- CONVERT CHARACTER TIME STEP TO MINUTES AND REAL NUMBER TIME STEP
  ! -------------------------------------------------------------
  SUBROUTINE CTimeStep_To_RTimeStep(UNITT,DELTAT,DELTAT_InMinutes,iStat)
    CHARACTER(LEN=*),INTENT(IN)  :: UNITT
    REAL(8),INTENT(OUT)          :: DELTAT
    INTEGER,INTENT(OUT)          :: DELTAT_InMinutes
    INTEGER,OPTIONAL,INTENT(OUT) :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+22) :: Thisprocedure = ModName // 'CTimeStep_To_RTimeStep'
    INTEGER                      :: TimeStepIndex

    !Initialize
    IF (PRESENT(iStat)) iStat = 0
    DELTAT_InMinutes = 0
    DeltaT           = 1.0 !DELTAT is always 1.0 since the unit includes the time step length, e.g. DELTAT = 1 12HOUR

    !Make sure that UNITT entry is a recognized time step
    TimeStepIndex = IsTimeIntervalValid(UNITT)
    IF (TimeStepIndex .EQ. 0) THEN
      IF (PRESENT(iStat)) THEN
          CALL SetLastMessage(TRIM(UNITT)// ' is not a recognized time step',iFatal,ThisProcedure)
          iStat = -1
          RETURN
      ELSE
          CALL LogMessage(TRIM(UNITT)// ' is not a recognized time step',iFatal,ThisProcedure)
      END IF
    END IF

    !Convert time step to Julian date increment "in terms of minutes"
    DELTAT_InMinutes = RecognizedIntervals_InMinutes(TimeStepIndex)

  END SUBROUTINE CTimeStep_To_RTimeStep

  ! -------------------------------------------------------------
  ! --- COMPUTE CONVERSION FACTOR BETWEEN TWO TIME INTERVALS
  ! -------------------------------------------------------------
  FUNCTION TimeIntervalConversion(ToInterval,FromInterval) RESULT(ConversionFactor)
    CHARACTER(LEN=*),INTENT(IN) :: ToInterval,FromInterval
    REAL(8)                     :: ConversionFactor

    !Local variables
    CHARACTER(LEN=ModNameLen+22) :: ThisProcedure = ModName // 'TimeIntervalConversion'
    REAL(8)                      :: DummyReal
    INTEGER                      :: FromInterval_InMinutes,ToInterval_InMinutes,ErrorCode

    !Convert FromInterval to minutes
    CALL CTimeStep_To_RTimeStep(UpperCase(FromInterval),DummyReal,FromInterval_InMinutes,ErrorCode)
    IF (ErrorCode.NE.0) CALL LogMessage(TRIM(UpperCase(FromInterval))//' is not a valid time interval!',iFatal,ThisProcedure)

    !Convert ToInterval to minutes
    CALL CTimeStep_To_RTimeStep(UpperCase(ToInterval),DummyReal,ToInterval_InMinutes,ErrorCode)
    IF (ErrorCode.NE.0) CALL LogMessage(TRIM(UpperCase(ToInterval))//' is not a valid time interval!',iFatal,ThisProcedure)

    ConversionFactor = REAL(ToInterval_InMinutes,8)/REAL(FromInterval_InMinutes,8)

 END FUNCTION TimeIntervalConversion

END MODULE

max_stars_repo_name: giorgk/IWFM-SAFE

max_issues_repo_name: giorgk/IWFM-SAFE

max_forks_repo_name: giorgk/IWFM-SAFE


text:
*----------------------------------------------------------------------*
      subroutine reo_mel_blk(meinp,meout,iblkinp,iblkout,
     &     str_info,strmap_info,orb_info,ifrom,ito,idxinp)
*----------------------------------------------------------------------*
*     reorder vertex ifrom to vertex ito and write result the list
*     of meout
*     Note that the reordering sign is ignored (i.e. set to 1).
*
*     matthias, dec 2009
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'
      include 'opdim.h'
      include 'def_orbinf.h'
      include 'mdef_operator_info.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_reorder_info.h'
      include 'ifc_memman.h'

      integer, parameter ::
     &     ntest = 00

      type(orbinf), intent(in) ::
     &     orb_info
      type(strinf), intent(in) ::
     &     str_info
      type(strmapinf), intent(in) ::
     &     strmap_info
      type(me_list), intent(in), target ::
     &     meinp, meout
      integer, intent(in) ::
     &     iblkinp, iblkout, ifrom, ito, idxinp

      integer ::
     &     njinp, njout, idoff_in, idoff_out, idum, imode,
     &     ij, ijinp, ijout, ngas
      real(8) ::
     &     xret_dum
      logical ::
     &     problem

      type(operator), pointer ::
     &     opinp, opout
      type(filinf), pointer ::
     &     ffin, ffout

      type(reorder_info) ::
     &     reo_info

      integer, pointer ::
     &     iocc_inp(:,:,:), iocc_out(:,:,:),
     &     irst_inp(:,:,:,:,:)

      integer, allocatable ::
     &     iocc(:,:,:), iocc_tmp(:,:,:),
     &     irst(:,:,:,:,:), irst_tmp(:,:,:,:,:),
     &     merge_stp1(:), merge_stp2(:), merge_stp1inv(:),
     &     merge_stp2inv(:), svertex(:),occ_vtx(:,:,:),
     &     info_vtx(:,:), irst_vtx(:,:,:,:,:)

      logical, external ::
     &     iocc_zero, iocc_equal

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,'reo_mel_blk')
      end if

      opinp => meinp%op
      opout => meout%op

      njinp = opinp%njoined
      njout = opout%njoined

      ngas = orb_info%ngas

      ! translate records to offset in file:
      ffin => meinp%fhand
      idoff_in = ffin%length_of_record*(ffin%current_record-1)
      ffout => meout%fhand
      idoff_out = ffout%length_of_record*(ffout%current_record-1)

      iocc_inp => opinp%ihpvca_occ(1:ngastp,1:2,
     &           (iblkinp-1)*njinp+1:iblkinp*njinp)
      iocc_out => opout%ihpvca_occ(1:ngastp,1:2,
     &           (iblkout-1)*njout+1:iblkout*njout)
      irst_inp => opinp%igasca_restr(1:2,1:ngas,1:2,1:2,1,
     &           (iblkinp-1)*njinp+1:iblkinp*njinp)

      call init_reo_info(reo_info)

      ! set reorder information: shift entire vertex
      allocate(reo_info%reo(2*njinp),reo_info%nca_vtx(njinp))
      reo_info%nvtx_contr = njinp
      call set_nca_vtx(reo_info%nca_vtx,iocc_inp,njinp)

      reo_info%nreo = 1
      reo_info%reo(1)%idxsuper = 1
      reo_info%reo(1)%idxop_ori = idxinp
      reo_info%reo(1)%iblkop_ori = 1
      reo_info%reo(1)%is_bc_result = .true.
      reo_info%reo(1)%reo_before = .false.
      reo_info%reo(1)%shift_i0 = .false.
      reo_info%reo(1)%to = ito
      reo_info%reo(1)%from = ifrom
      reo_info%reo(1)%to_vtx   = ito
      reo_info%reo(1)%from_vtx = ifrom
      reo_info%reo(1)%occ_shift = iocc_inp(1:ngastp,1:2,ifrom)

      ! most arrays here are just dummies
      allocate(iocc(ngastp,2,njinp), iocc_tmp(ngastp,2,njinp),
     &     irst(2,ngas,2,2,njinp),
     &     irst_tmp(2,ngas,2,2,njinp),
     &     merge_stp1(2*njinp*njinp), merge_stp2(2*njinp*njinp),
     &     merge_stp1inv(2*njinp*njinp), merge_stp2inv(2*njinp*njinp),
     &     svertex(njinp),occ_vtx(ngastp,2,2*njinp),
     &     info_vtx(2,2*njinp),irst_vtx(2,ngas,2,2,2*njinp))

      iocc = iocc_inp
      iocc(1:ngastp,1:2,ito) = iocc(1:ngastp,1:2,ito)
     &       + iocc(1:ngastp,1:2,ifrom)
      iocc(1:ngastp,1:2,ifrom) = 0
      irst = irst_inp
      irst(1:2,1:ngas,1:2,1:2,ito) = irst(1:2,1:ngas,1:2,1:2,ito)
     &       + irst(1:2,1:ngas,1:2,1:2,ifrom)
      irst(1:2,1:ngas,1:2,1:2,ifrom) = 0

      ! now there should be a one-to-one correspondence to the output op.
      problem = .false.
      do ij = 1, njout
        if (.not.iocc_zero(iocc_out(1:ngastp,1:2,ij))) then
          ijout = ij
          exit
        end if
      end do
      do ijinp = 1, njinp
        if (iocc_zero(iocc(1:ngastp,1:2,ijinp))) cycle
        problem = problem.or.
     &            .not.iocc_equal(iocc_out(1:ngastp,1:2,ijout),
     &              .false.,iocc(1:ngastp,1:2,ijinp),.false.)
        do ij = ijout+1, njout
          if (.not.iocc_zero(iocc_out(1:ngastp,1:2,ij))) then
            ijout = ij
            exit
          end if
        end do
      end do
      do ij = ijout+1, njout
        problem = problem.or..not.iocc_zero(iocc_out(1:ngastp,1:2,ij))
      end do
      if (problem) call quit(1,'reo_mel_blk','ops do not match?')

      svertex = 1
      occ_vtx(1:ngastp,1:2,1:njinp) = iocc_inp
      occ_vtx(1:ngastp,1:2,njinp+1:2*njinp) = iocc
      irst_vtx(1:2,1:ngas,1:2,1:2,1:njinp) = irst_inp
      irst_vtx(1:2,1:ngas,1:2,1:2,njinp+1:2*njinp) = irst

      do imode = 1, 2
        call get_reo_info2(imode,1,
     &         iocc,iocc_tmp,
     &         irst,irst_tmp,
     &         njinp,idum,idum,
     &         merge_stp1,merge_stp1inv,merge_stp2,merge_stp2inv,
     &         occ_vtx,irst_vtx,svertex,info_vtx,njinp,njinp,
     &         reo_info,reo_info%nreo,str_info,orb_info)
      end do

      ! Ignore reordering sign (we just want to change the shape, sign
      ! changes shall be accounted separately in other steps if needed)
      if (reo_info%sign_reo.ne.1d0) then
c        write(lulog,*) 'setting sign_reo = +1 for block ',iblkout
        reo_info%sign_reo = 1d0
      end if

      call reo_op_wmaps_c(1d0,
     &     .false.,xret_dum,0,
     &     meinp,meout,
     &     .false., .false.,
     &     iblkinp,iblkout,
     &     idoff_in,idoff_out,
     &     reo_info,
     &     str_info,strmap_info,orb_info)

      call dealloc_reo_info(reo_info)

      deallocate(iocc,iocc_tmp,
     &     irst,irst_tmp,merge_stp1,merge_stp2,
     &     merge_stp1inv,merge_stp2inv,
     &     svertex,occ_vtx,info_vtx,irst_vtx)

      return
      end

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


text:
	SUBROUTINE SFXGST  ( parms, icolor, data, ntime, xval, iret )
C************************************************************************
C* SFXGST								*
C*									*
C* This subroutine plots character data for SFGRAM.			*
C*									*
C* SFXGST  ( PARMS, ICOLOR, DATA, NTIME, XVAL, IRET )			*
C*									*
C* Input parameters:							*
C*	PARMS		CHAR*		Parm*condition			*
C*	ICOLOR		INTEGER		Color				*
C*	DATA (NTIME)	REAL		Data				*
C*	NTIME		INTEGER		Number of times			*
C*	XVAL (NTIME)	REAL		Points on x axis		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 5/90						*
C* S. Jacobs/NCEP	 9/97	Changed call to GQTEXT and GSTEXT	*
C* T. Piper/SAIC	07/05	Added gchar variable			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	parms
	REAL		xval (*), data (*)
C*
	CHARACTER	condtn*8, gchar*4, ppp*4
C*
	INCLUDE		'ERMISS.FNC'
	DATA		gchar / 'G' /
C------------------------------------------------------------------------
	iret = 0
C
C*	Get the condition and parameter parts.
C
	condtn = parms (5: )
	ppp    = parms
C
C*	Set color.
C
	CALL GSCOLR  ( icolor, ier )
C
C*	Get conditions.
C
	CALL SFXCND  ( condtn, size, iwidth, ier )
C
C*	Set the character size and width.
C
	CALL GQTEXT  ( itxfn, itxhw, sztext, itxwid,
     +		       ibrdr, irrotn, ijust, ier )
	CALL GSTEXT  ( 0, 0, size, iwidth, 0, 0, 0, ier )
C
C*	Loop through points writing text.
C
	DO  i = 1, ntime
	    IF  ( .not. ERMISS ( data (i) ) .and.
     +		  ( data (i) .gt. 0. ) )  THEN
		CALL GTEXT  ( 'M', xval (i), data (i), gchar, 0., 0, 0,
     +					ier )
	    END IF
	END DO
C
C*	Reset text attributes.
C
	CALL GSTEXT  ( 0, 0, sztext, itxwid, 0, 0, 0, ier )
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      SUBROUTINE SCFT (A, MODE, M, ND, MS, S)
c>> 1997-03-31 SCFT Krogh  Increased KEDIM, more sine table checks.
C>> 1994-10-20 SCFT Krogh  Change CERROR to simplify conversion to C.
C>> 1994-10-20 SCFT Krogh  Changes to use M77CON
C>> 1994-04-19 SCFT CLL Edited to make DP & SP files similar.
c>> 1989-06-16 FTK Fix error message on MODE.
c>> 1989-06-05 WVS Change length of MODE from *(ND) to *(*).
c>> 1989-05-07 FTK & CLL
c>> 1989-04-21 FTK & CLL
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c
c     This subroutine computes complex Fourier transforms in up to 6
c     dimensions using the Cooley-Tukey fast Fourier transform.
c
c     Variables in the calling sequence have the following types.
      REAL             A(*), S(*)
      INTEGER  ND, M(ND), MS
      CHARACTER MODE*(*)
c
c     Programmed by Fred T. Krogh at the Jet Propulsion Laboratory,
c     Pasadena, Calif.   August 1, 1969.
c
c     Values for A, MODE, M, ND, and MS must be specified before
c     calling the subroutine.
c
c     In describing the usage the following notation is used
c     N(K) = 2**M(K)
c     WK = EXP(2*PI*I/N(K)), where I = sqrt(-1) and PI = 3.14159...
c     MA = M(1) + M(2) + ... + M(ND)
c     NA = 2**MA
c     MX = MAX(M(1), M(2), ..., M(ND))
c     NX = 2**MX
c
c The usage is as follows
c
c A() on input is an array of function values, X, if one is doing
c   Fourier analysis,
c   and is an array of Fourier coefficients, C, if one is
c   doing Fourier synthesis.  On output, A contains C if doing analysis,
c   and contains X if doing synthesis.  In our description here, we
c   assume that A has been declared by the user as a complex array with
c   dimension A(N(1),N(2),...,N(ND)). (Of course this is not necessary
c   as long as one declares enough storage for A, and keeps in mind that
c   the array is treated in this subroutine as if it had been specified
c   in this way.)  It is assumed that the imaginary part of a complex
c   number is stored in the cell immediately following its real part.
c
c MODE  A character variable of length at least ND.
c   The k-th character must be 'A' or 'a' to select Analysis in the
c   k-th dimension, or 'S' or 's' to select Synthesis in the
c   k-th dimension.
c   The subroutine sets  A(j1+1, j2+1, ..., jND+1) to the sum
c  over 0 .le. k1 .le. N(1)-1, 0 .le. k2 .le. N(2)-1, ...,
c  0 .le. kND .le. N(ND)-1 of A(k1+1, k2+1, ..., kND+1) * T(1,j1,k1) *
c  T(2,j2,k2) * ... * T(ND,jND,kND), 0 .le. j1 .le. N(1)-1, ...,
c  0 .le. jnd .le. N(ND)-1
c  with T(L,j,k) =
c        WL ** (j*k)               if MODE(L:L) = 'S' or 's'
c        (1/N(L)) * WL ** (-j*k)   if MODE(L:L) = 'A' or 'a'
c
c M() is a vector used to indicate N(k) = 2**M(k), the number of
c  complex points in the k-th variable.  M must be such that MX < 21.
c  If M(L)=0, no change is made with respect to the L-th dimension.
c
c ND is the dimension of (i.e. the number of subscripts in) the
c    array A.  ND must satisfy 1 .le. ND .le. 6
c
c MS gives the state of the sine table.  If MS > 0, there are NT =
c    2 ** (MS-2) good entries in the sine table.  On the initial call,
c    MS must be set to 0, and when the return is made, it will be set
c    to MX, which is the value of MS required for computing a
c    transform of size NX.  If MS = -1, the sine table will be computed
c    as for the case MS = 0, and then a return to the user will be made
c    with MS set as before, but no transform will be computed.  This
c    option is useful if the user would like access to the sine table
c    before computing the FFT.
c
c S is a vector, S(j) = sin(pi*j/(2*NT)), j = 1, 2, ..., NT-1, where
c  NT is defined in the description of MS above.  S is computed by the
c  subroutine if MX .gt. MS.  (If S is altered, set MS=0 so that S
c  is recomputed.)
c     ------------------------------------------------------------------
c                Notes on COMMON, PARAMETER's, and local variables
C
c     NDMAX = the maximum value for ND, and MAXM = the maximum
c     permitted for M(1), ..., M(ND)
c     The dimension of KE must be at least as large as MAXM.
c     The named common CSFFTC is used for communication between this
c     subroutine and the subroutine SFFT which computes a one
c     dimensional complex Fourier transform and computes the sine table.
c     The use of the variables in CSFFTC is contained in the listing
c     of SFFT.
c
c     NF(1) = 2, NF(K+1) = 2**(1+M(1)+...+M(K)), K = 1,..., ND
c     ------------------------------------------------------------------
c--S replaces "?": ?CFT, ?FFT, C?FFTC
c     Both versions use IERM1
c     ------------------------------------------------------------------
      INTEGER MAXM, NDMAX
      PARAMETER (NDMAX = 6)

      INTEGER I, II, IIC, IR, IRC
      INTEGER J, JL
      INTEGER K, KEDIM, KSM
      INTEGER L
      INTEGER MA, MMAX, MSI
      INTEGER NDD, NF(NDMAX+1), NTOT2

      CHARACTER*13  CERROR

      REAL             FN, ONE, SPI4

      PARAMETER (ONE = 1.E0)
      PARAMETER (SPI4 = .70710 67811 86547 52440 08443 62104 8490E0)

c Common variables
      PARAMETER (KEDIM=30)
      LOGICAL NEEDST
      INTEGER MT, NT, MM, KS, ILAST, KE(KEDIM), KEE(KEDIM+1)
c Note that KEE(1) is equivalent to ILAST.
      EQUIVALENCE (KE(1), KEE(2))
      COMMON /CSFFTC/ NEEDST, MT, NT, MM, KS, ILAST, KE
      SAVE /CSFFTC/
      PARAMETER (MAXM = KEDIM)
      DATA CERROR / 'MODE(K:K) =  ' /
c     ------------------------------------------------------------------
c
      NDD = ND
      IF ((NDD .LE. 0) .OR. (NDD .GT. NDMAX)) THEN
c                               Fatal error, default is to stop in IERM1
         CALL IERM1 ('SCFT', 1, 2, 'BAD ND', 'ND', ND, '.')
         MS = -2
         RETURN
      END IF
      NF(1) = 2
      MA = 0
      MMAX = 0
      FN = ONE
      DO 10 K = 1, NDD
         MM = M(K)
         MMAX = MAX(MM, MMAX)
         MA = MA + MM
         I = 2**MM
         IF ((MM .LT. 0) .OR. (MM .GT. MAXM)) THEN
c                               Fatal error, default is to stop in IERM1
         CALL IERM1('SCFT',2,2,'Need 0 .le. M(K) .le. 30','M(K)',MM,'.')
         MS = -2
         RETURN
         END IF
         NF(K+1) = NF(K) * I
         if (MODE(K:K) .eq. 'A' .or. MODE(K:K) .eq. 'a') then
            FN = FN / I
         else if (MODE(K:K) .ne. 'S' .and. MODE(K:K) .ne. 's') then
            CERROR(13:13) = MODE(K:K)
            CALL IERM1 ('SCFT',3,2,CERROR, 'for K =',K,'.')
            MS = -2
            RETURN
         end if
   10 CONTINUE
      MSI = MS
      NEEDST = MMAX .GT. MSI
      if (.NOT. NEEDST) then
c  Check internal parameters to catch certain user errors.
         if (MT .lt. KEDIM) then
            if (MMAX .le. MT + 2) then
c              Skip sine table computation if all appears O.K.
               if (MT .le. 0) go to 20
               if (abs(S(NT/2) - SPI4) .le. 1.E-7) go to 20
            end if
         end if
         NEEDST = .true.
         call ERMSG('DRFT1', 3, 1,
     1      'Invalid sine table (re)computed', '.')
      end if
      MS = MMAX
      MT = MMAX - 2
      CALL SFFT (A, A, S)
      IF (MSI .EQ. -1) RETURN
c                   All setup for computation now
   20 NTOT2 = NF(NDD+1)
      IF (FN .NE. ONE) THEN
         DO 30 I = 1, NTOT2
            A(I) = A(I) * FN
   30    CONTINUE
      END IF
c     Beginning of loop for computing multiple sum
      DO 70 K = 1, NDD
         if(MODE(K:K) .eq. 'A' .or. MODE(K:K) .eq. 'a') then
            IRC = 1
            IIC = 0
         ELSE
            IRC = 0
            IIC = 1
         END IF
         MM = M(K)
         KS = NF(K)
         KSM = KS - 1
         ILAST = NF(K+1)
         DO 40 L = 1, MM
            KEE(L+1) = KEE(L) / 2
   40    CONTINUE
         DO 60 J = 1, NTOT2, ILAST
            JL = J + KSM
            DO 50 I = J, JL, 2
               IR = I + IRC
               II = I + IIC
               CALL SFFT (A(IR), A(II), S)
   50       CONTINUE
   60    CONTINUE
   70 CONTINUE
      RETURN
c        End of loop for computing multiple sum
c
      END


text:
C     File: goto_06.f
C     A simple program with a single forward conditional goto and
C     a single backward unconditional goto.
C     The program computes and prints out the values of n! for n in [1,10].

      program factorial
      implicit none

      integer i, n, fact

      i = 0
      n = 10
      fact = 1

 111  i = i + 1

      if (i .le. n) goto 222

      stop

 222  fact = fact * i

      write (*, 10) i, fact

      goto 111

 10   format('i = ', I3, '; fact = ', I8)

      end program factorial


text:
module fycollections
  use, intrinsic :: iso_c_binding
  use fycollections_interfaces
  use fycollections_ptrlist
  implicit none

end module fycollections

ext: fpp

max_stars_repo_name: aradi/fycollections

max_issues_repo_name: aradi/fycollections

max_forks_repo_name: aradi/fycollections