text:
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

! find largest spherical hole in a configuation starting from some initial guess
#include "error.inc"
module find_space_minim_mod
use libatoms_module
use iso_c_binding, only : c_ptr, c_loc, c_f_pointer
implicit none

real(dp), save :: rad, width

contains

  ! x > r   fo = 1-cos((x-r)/w * pi/2 + 3 pi /2)
  ! f'(r) = sin(3 pi /2) pi/(2 w) = -pi/(2 w)
  ! x <= r  fi = o - x pi/(2 w)
  ! fi(r) = fo(r)
  ! 1 = o - r pi/(2 w)
  ! o = 1 + r pi / (2 w)

function func(x,data)
  real(dp) :: x(:)
  character, optional :: data(:)
  real(dp) :: func

  integer :: i
  type(c_ptr) :: at_ptr
  type(Atoms), pointer :: at
  real(dp) :: r_mag

  if (.not. present(data)) call system_abort("find_space_minim_mod func needs data")
  if (size(x) /= 3) call system_abort("find_space_minim_mod func needs x(1:3)")

  at_ptr = transfer(data, at_ptr)
  call c_f_pointer(at_ptr, at)
  call atoms_repoint(at)

  func = 0.0_dp
  do i=1, at%N
    r_mag = distance_min_image(at, i, x(1:3))
    if (r_mag < rad) then
      func = func + rep_E(r_mag)
    endif
  end do

end function func

function dfunc(x,data)
  real(dp) :: x(:)
  character, optional :: data(:)
  real(dp) :: dfunc(size(x))

  integer :: i
  type(c_ptr) :: at_ptr
  type(Atoms), pointer :: at
  real(dp) :: r(3), r_mag

  if (.not. present(data)) call system_abort("find_space_minim_mod func needs data")
  if (size(x) /= 3) call system_abort("find_space_minifind_space_minimeds x(1:3)")

  at_ptr = transfer(data, at_ptr)
  call c_f_pointer(at_ptr, at)
  call atoms_repoint(at)

  dfunc = 0.0_dp
  do i=1, at%N
    r = diff_min_image(at, i, x(1:3))
    r_mag = norm(r)
    if (r_mag < rad) then
      dfunc = dfunc + rep_dE(r, r_mag)
    endif
  end do

end function dfunc

subroutine apply_precond_dummy(x,g,P_g,data,error)
  real(dp) :: x(:), g(:), P_g(:)
  character, optional :: data(:)
  integer, optional :: error

  INIT_ERROR(error)
  P_g = g

end subroutine apply_precond_dummy

subroutine bothfunc(x,E,f,data,error)
  real(dp) :: x(:), E, f(:)
  character, optional :: data(:)
  integer,optional :: error

  integer :: i
  type(c_ptr) :: at_ptr
  type(Atoms), pointer :: at
  real(dp) :: r(3), r_mag

  INIT_ERROR(error)

  if (.not. present(data)) call system_abort("find_space_minim_mod func needs data")
  if (size(x) /= 3) call system_abort("find_space_minim_mod bothfunc needs x(1:3)")

  at_ptr = transfer(data, at_ptr)
  call c_f_pointer(at_ptr, at)
  call atoms_repoint(at)

  f = 0.0_dp
  E = 0.0_dp
  do i=1, at%N
    r = diff_min_image(at, i, x(1:3))
    r_mag = norm(r)
    if (r_mag < rad) then
      E = E + rep_E(r_mag)
      f = f + rep_dE(r, r_mag)
    endif
  end do

end subroutine bothfunc

function rep_E(r_mag)
   real(dp) :: r_mag
   real(dp) :: rep_E

   real(dp) :: f_envelope

   if (r_mag > rad) then
      f_envelope = 0.0_dp
   else if (r_mag < rad-width) then
      f_envelope = 1.0_dp
   else
      f_envelope = 0.5_dp+0.5_dp*cos((r_mag-(rad-width))/width * 3.14159_dp)
   endif

   rep_E = (2.0_dp - r_mag/rad) * f_envelope

end function rep_E

function rep_dE(r, r_mag)
   real(dp) :: r(:), r_mag
   real(dp) :: rep_dE(size(r))

   real(dp) :: f_envelope, df_envelope

   if (r_mag > rad) then
      f_envelope = 0.0_dp
      df_envelope = 0.0_dp
   else if (r_mag < rad-width) then
      f_envelope = 1.0_dp
      df_envelope = 0.0_dp
   else
      f_envelope = 0.5_dp+0.5_dp*cos((r_mag-(rad-width))/width * 3.14159_dp)
      df_envelope = -0.5_dp*sin((r_mag-(rad-width))/width * 3.14159_dp) * (1.0_dp/width) * 3.14159_dp
   endif

   rep_dE = ((2.0_dp - r_mag/rad) * df_envelope  - 1.0_dp/rad * f_envelope) * r/r_mag
end function rep_dE

subroutine hook(x,dx,E,done,do_print,data)
  use system_module
  real(dp), intent(in) ::x(:)
  real(dp), intent(in) ::dx(:)
  real(dp), intent(in) ::E
  logical, intent(out) :: done
  logical, optional, intent(in) :: do_print
  character(len=1),optional, intent(in) ::data(:)

  done = norm(dx) .feq. 0.0_dp

end subroutine hook

end module find_space_minim_mod

program find_space_minim
use libatoms_module
use find_space_minim_mod, only : func, bothfunc, apply_precond_dummy, hook, rad, width
use iso_c_binding, only : c_ptr, c_loc, c_f_pointer
implicit none

  real(dp) :: r(3), prev_r(3), orig_r(3)
  integer :: closest_list(100)
  type(Atoms) :: at
  type(Atoms), target :: closest_at
  type(c_ptr) :: closest_at_ptr
  character(len=128) :: arg
  integer :: data_size
  character, allocatable :: data(:)
  integer :: i_r, n_iter
  real(dp) :: prev_val, final_val, prev_rad
  integer :: i_at
real(dp) :: vi, vf
  real(dp) :: expected_red
  real(dp) :: rad_min, rad_increment

  call system_initialise()
  call read(at, "stdin")
  call get_cmd_arg(1, arg)
  read (unit=arg, fmt=*) r(1)
  call get_cmd_arg(2, arg)
  read (unit=arg, fmt=*) r(2)
  call get_cmd_arg(3, arg)
  read (unit=arg, fmt=*) r(3)
  call get_cmd_arg(4, arg)
  read (unit=arg, fmt=*) rad_min
  call get_cmd_arg(5, arg)
  read (unit=arg, fmt=*) rad_increment

  do i_at=1, at%N
    at%pos(1:3,i_at) = at%pos(1:3,i_at) - r(1:3)
  end do
  call map_into_cell(at)
  orig_r = r
  r = 0.0_dp

  if (at%N < 100) then
     call find_closest(at, r, closest_list(1:at%N))
     call select(closest_at, at, list=closest_list(1:at%N))
  else
     call find_closest(at, r, closest_list)
     call select(closest_at, at, list=closest_list)
  endif

  closest_at_ptr = c_loc(closest_at)
  data_size = size(transfer(closest_at_ptr, data))
  allocate(data(data_size))
  data = transfer(closest_at_ptr,data)
  width = 0.2_dp

  i_r = 1
  prev_val = 0.0_dp
  final_val = 0.0_dp
  prev_r = 0.0_dp
  do while (final_val <= 1.0e-3 .and. i_r < 1000)
    prev_r = r
    prev_val = final_val
    rad = rad_min+(i_r-1)*rad_increment
    call verbosity_push(PRINT_SILENT)
    ! n_iter = minim(r, func, dfunc, 'cg', 1.0e-6_dp, 1000, 'NR_LINMIN', eps_guess=1e-3_dp, hook=hook, data=data)
    expected_red = 1.0e-2_dp
    n_iter = n_minim(r, bothfunc, .false., apply_precond_dummy, vi, vf, expected_red, 1000, 1e-8_dp, hook=hook, data=data)
    final_val = func(r, data)
    call verbosity_pop()
    call find_closest(at, r, closest_list(1:1))
    call print("rad " // rad// " n_iter " // n_iter // " relaxed val " // func(r, data) // " relaxed r" // r &
      // " radius " // distance_min_image(at,closest_list(1),r))
    i_r = i_r + 1
  end do

  r = r + orig_r
  prev_r = prev_r + orig_r
  do i_at=1, at%N
    at%pos(1:3,i_at) = at%pos(1:3,i_at) + orig_r(1:3)
  end do

  if (i_r == 2) then
    call print("WARNING: first try found no space at rad " // rad)
  else
    call find_closest(at, prev_r, closest_list(1:1))
    prev_rad = distance_min_image(at,closest_list(1),prev_r)

    call print("best r " // prev_r // " best_rad " // prev_rad // " best_val " // prev_val // " next_val " // final_val)
  endif

  call system_finalise()
end program

max_stars_repo_name: albapa/QUIP

max_issues_repo_name: albapa/QUIP

max_forks_repo_name: albapa/QUIP


text:
c*************************************************************************
c                            STEP_DKD_TP.F
c*************************************************************************
c This subroutine takes a step in helio coord.
c Does a DRIFT than a KICK than a DRIFT.
c ONLY DOES TEST PARTICLES
c
c             Input:
c                 i1st           ==>  = 0 if first step; = 1 not (int scalar)
c                                     not used here !!!
c                 nbod           ==>  number of massive bodies (int scalar)
c                 ntp            ==>  number of massive bodies (int scalar)
c                 mass           ==>  mass of bodies (real array)
c                 j2rp2,j4rp4    ==>  J2*radii_pl^2 and  J4*radii_pl^4
c                                     (real scalars)
c                 xhm,yhm,zhm   ==>  massive part position in middle of step
c                                       (real arrays)
c                 xht,yht,zht    ==>  initial part position in helio coord
c                                      (real arrays)
c                 vxht,vyht,vzht ==>  initial velocity in helio coord
c                                        (real arrays)
c                 istat           ==>  status of the test paricles
c                                      (2d integer array)
c                                      istat(i,1) = 0 ==> active:  = 1 not
c                                      istat(i,2) = -1 ==> Danby did not work
c                 dt             ==>  time step
c             Output:
c                 xht,yht,zht    ==>  final position in helio coord
c                                       (real arrays)
c                 vxht,vyht,vzht ==>  final position in helio coord
c                                       (real arrays)
c
c Remarks: Adopted from martin's nbwh.f program
c Authors:  Hal Levison
c Date:    2/12/93
c Last revision: 2/12/93

      subroutine step_dkd_tp(i1st,nbod,ntp,mass,j2rp2,j4rp4,
     &     xhm,yhm,zhm,xht,yht,zht,vxht,vyht,vzht,istat,dt)

      include '../../swift.inc'

c...  Inputs Only:
      integer nbod,ntp,i1st
      real*8 mass(nbod),dt,j2rp2,j4rp4
      real*8 xhm(nbod),yhm(nbod),zhm(nbod)

c...  Inputs and Outputs:
      integer istat(NTPMAX,NSTAT)
      real*8 xht(ntp),yht(ntp),zht(ntp)
      real*8 vxht(ntp),vyht(ntp),vzht(ntp)

c...  Internals:
      real*8 dth
      real*8 axht(NTPMAX),ayht(NTPMAX),azht(NTPMAX)

c----
c...  Executable code

      dth = 0.5d0*dt

c...  Take a drift forward 0.5dt to begin the step (the first kick = 0).
      call drift_tp(ntp,mass(1),xht,yht,zht,vxht,vyht,vzht,dth,istat)

c...  Get the accelerations in helio frame.
      call getacch_tp(nbod,ntp,mass,j2rp2,j4rp4,xhm,yhm,zhm,
     &                xht,yht,zht,istat,axht,ayht,azht)

c...  Apply a heliocentric kick for a full dt
      call kickvh_tp(ntp,vxht,vyht,vzht,axht,ayht,azht,istat,dt)

c..   Drift again in Jacobi coords for the final half-step 0.5dt
      call drift_tp(ntp,mass(1),xht,yht,zht,vxht,vyht,vzht,dth,istat)

      return
      end   ! step_dkd_tp
c---------------------------------------------------------------------

ext: f

max_stars_repo_name: Simske/exostriker


text:
 Image(Avid Reader Store Front.jpg, right, thumbnail, 350)

The Avid Reader is one of the longstanding independent Bookstores bookstores in Davis. They have a decent selection and the staff is always friendly. They are pretty much the only Davis book store to host local and touring authors for public readings. Check their http://avidreader.indiebound.com/event event web page or their Davis Enterprise ad. They also have The Avid Reader Book Club.  Free gift wrapping is available year round.

As of June 2011, http://www.davisenterprise.com/localnews/ebooksavailablenowatindependentbookstores/ Google eBooks can be purchased from The Avid Reader website, allowing one to support their local bookstore while retaining the convenience of an ebooks ebook.  According to http://www.wgntv.com/blogs/leshockvalue/wgntvwatchgooglehelpingindependentbookstoressellebooks20110725,0,1397070.story this news story, Google is offering this service to independent bookstores for free, hoping that customers will become loyal to Google eBooks.

In March 2006, owner Alzada Knickerbocker was named state http://www.nfib.com/object/IO_27321.html SmallBusiness Champion of the Year by the http://www.nfib.com National Federation of Independent Business.  The Avid Reader underwent a remodel in 2009.

Avid Reader Active opened in June of 2012, filling a space just two doors down (formerly occupied by Alphabet Moon). Avid Reader Active focuses on stocking nonfiction titles, whereas Avid Reader now deals mainly in fiction.

The Avid Reader also has a wiki:sacramento:Avid Reader at the Tower sister store in Sacramento.

This place gets a big meh from me. The selection is too small and the prices are too high.  Users/Eyaddarras

20060727 12:46:25 nbsp The Avid Reader holds awards for best bookstore, best customer service, and best independent retailer. Services include overnight special ordering (with free shipping), online ordering at www.avidreaderbooks.com, and fast searches for used, difficult to obtain, and out of print books. Teachers receive a 20% discount for classroom orders. Bookclub groups are welcome and receive a 20% discount on their bookclub selections. The store hosts its own bookclub that meets monthly and is always open to new members. Its Children’s Book Loft is a popular destination for young readers. There are signups for American Girls Bookclub meetings held regularly in the Loft. The store is recognized for a staff that is fast, friendly and knowledgeable, an extensive book selection including the best in print for the readers of Davis, strong support of local authors that includes dozens of booksignings annually, contributions to local organizations, and sponsorships of community programs.  Users/TheAvidReader

20060727 12:47:22 nbsp If they dont have what I want in stock, they can get it for me fairly fast.  They also put on the Harry Potter nights over the last few book releases.  Great community participation!  Good store to support. Users/SharlaDaly

20060823 10:37:14 nbsp Today the Sacramento Bee featured an article that quoted Alzada Knickerbocker as being opposing to the minimum wage increase. Sort of surprising seeing as I would expect the Avid Reader to pay better in Davis where the cost of living is much higher. Guess it goes to show you cant always judge a book by its cover. Users/EnirytManaen

20070516 04:41:58 nbsp Interesting to read the comment above  I believe it.  I went for a job interview once and met the owner.  She appeared to be quite full of herself and kept focusing on how everyone tells her how great her bookstore was instead of doing my interview.  Anyhow I ended with a better job offer elsewhere, but...ugh...youre better off going to any other of the many bookstores in Davis since this one has a lousy selection and is way overpriced. Users/christinegallo

20070524 16:00:44 nbsp They have copies of my dads book for sale!   <3 Users/StevenDaubert

20071214 00:11:34 nbsp Im glad we still have an independent bookstore downtown, but I wish I could be more enthusiastic about this one. One of my biggest gripes is the dog upstairs. Why is a dog that is freaked out by children kept right next to the childrens section? They would sell more books if they found another daytime accommodation for this poor dog. I take my childrens book business to Bordersits bigger, cheaper, and my children can go to the kids section without being scared out of their wits. Im no doghater. (Pomegranate, the hair place on F St., has a lovely, lovely dog who belongs to the owners.) This is one instance of the sort of lack of sense about customer needs that eventually leads to loss of business & business closure, which then gets blamed (unfairly, IMHO) on Borders and Amazon. I wish someone who really loved both books & people would open a bookstore here! Users/PrimulaBaggins

20071214 22:28:19 nbsp Best selection of books in Davis. Excellent staff and their special order system is fast and efficient. Many books by local authors. Lots of great calendars around the holidays, good map selection. They have normal retail pricing, discounts on some books and a shopper card you can use to save money.
BTW, every time Ive been in the store, which is many, many times over the years, the dog has been confined behind the child gate upstairs, and is usually curled up in her corner or in her carrier. The owner is very active in downtown events and is a big supporter of local community groups.  Users/DonShor

20081008 14:31:12 nbsp I need to update that picture with one where cars arent blocking the front tables... Users/SunjeetBaadkar

20090701 15:25:26 nbsp Its a little bit surprising, since the store is physically much smaller, but the variety of books offered by Avid is probably comparable to that of Borders.  Borders shelves are (increasingly) occupied by empty space, books on display sideways, and signs telling you to look at other books.  Avids shelves are densely packed with one of just about everything.  While Im sure they dont have the diversity of Amazon, Ive been in there on a number of occasions, and always found what what I was looking for.  Highly recommended.

One concern though  I think I mentioned this on the Borders page as well at one point  it is becoming increasingly difficult to find novels in trade paperback format.  Books that should cost $7 or so cost $16 or more, and dont seem to be available in less expensive formats.  At those prices, it often feels like a better choice to try to find books at the library, to exchange books with friends, or to seek other alternatives (including Amazon, which is often somewhat cheaper).  Id rather support my local bookstores if I can, but if prices continue to increase, that may not be an option. Users/IDoNotExist
   Go to Sweet Briar Books over on G Street in East Davis; plenty of packed shelves, no gimmicks. Users/BrianJKenyon
    What gimmicks do we have, if you dont mind me asking?  Users/SunjeetBaadkar
    Answer, in two words: author selection: compared to Sweet Briar: relatively uneclectic. Their secondhand/remainder shelf contents built to different dimensions though, of course...Users/BrianJKenyon
     Well, The Avid Reader literally consists of the staff that you see at the top of the page and has stayed static for quite a while now (at least a couple years).  The inventory manager does most of the ordering, but all the employees order for the store as well.  We basically control the stores inventory as a group and decide what we want (and yes, we order some random things on whim because we feel like it should be here even if it doesnt sell) individually or as a group.  We also take customer recommendations into consideration when someone walks in and says we should order a book for the store to carry.  So if there is every anything that you think we should have, definitely come on by and wed be willing to hear what you have to say. Users/SunjeetBaadkar

20090720 01:01:50 nbsp What kind of renovations are being performed?  It looked like some pretty extensive changes were being made when I biked by. Users/IDoNotExist

20090731 10:54:07 nbsp Well, for the most part, the changes are done, but there are still a few more things happening.  Over the last two weeks, we have added wheels to all the bookshelves so we can move them around on whim, changed the carpets, repainted the walls, redid the tile in the front of the store (inside and out), refinished the wooden surfaces, redid the staircase that leads to the kids loft and have been doing minor changes to the store arrangement overall.  Suffice to say, me and the other employees are physically tired, but there are still more changes to come.  Come on by and check it out. Users/SunjeetBaadkar
   Is the community bulletin board going back up in the display window when the paint dries? Users/BrianJKenyon
     Yes, it will be back up, but were still not sure when.  Were trying to decide on the current positioning of everything in the store and probably wont be doing anything for a couple weeks.  Were toying with the idea of putting up a much larger bulletin board in the back hallway so that there isnt as much fighting over space.  Also, if we do that and put one up front, wed end up having the front reserved for downtown events and nonprofit events only.  But since wed have to punch holes in the wall to mount these things, were not doing it until were set on an idea. Users/SunjeetBaadkar

20090829 22:03:03 nbsp I love the Avid Reader.  The selection is excellent, the atmosphere inviting and relaxing, the staff are excellent, and they are involved in and supportive of the local community.  Where else can you go that the staff keep you in mind when new books come in that you might be interested in and let you know?  Definitely one of my very favorite places in Davis. Users/davisdebbie

20090904 20:45:06 nbsp The bulletin board is back up!  To accommodate the demand, weve more than doubled the size of it and moved it to the back hallway since that area gets more foot traffic than the front corner did.  Please tell the employees before posting something so that it is guaranteed to stay up (as things just randomly posted may be pulled down). Users/SunjeetBaadkar

20100414 08:50:05 nbsp I do not recommend this store to parents with small children.  I tried to take my young children upstairs to the kids section.  Unfortunately, the owner keeps a large, aggressive dog in an area upstairs right next to the kids section.  The dog lunged, snapped and growled at my kids and left them crying and cowering.  When I inquired with the people that work there they reacted with indifference.  I havent been back since.   Users/sys$hobbit

  I would like to apologize for this incident and the lack of action. We, at the Avid Reader, try to keep our customers happy in all ways possible. The owners dog (a foxhound) was in an accident years ago and has been a bit finicky when left alone upstairs. We have been trying to adjust her behavior but when customers stare at her, she gets nervous and reverts to a protective stance. Unfortunately, simply removing her from this store would not help her in anyway since she has to get used to this. She has been getting better in her behavior over the years and has never once bit anyone but sometimes we falter in our ability to control her. I invite you to come back and give us a second chance. We could introduce the dog to you and your children so that she would later recognize you if you would like. Users/SunjeetBaadkar, Store Publicist

20100629 11:48:20 nbsp That dog scared once when I was getting a book upstairs. I was terrified, but the book select at the Avid Reader is pretty good and it is a local buisness so you know money spent there will go back to the community.  Users/BryceH

20110510 09:55:45 nbsp I dont know about the traumatized dog, but I do know that I was in the store once and overheard the owner talking loudly on the phone about the necessity of sending more donations to Michelle Bachmann (yes, that Michelle the census is a communist plot and we have a communist president and the activist judges are turning our children into homosexual muslims Bachmann). Ill admit that since then Ive been torn between wanting my consumer dollars to stay in Davis and wanting my consumer dollars to stay out of the Tea Party coffers. Users/Swilltopower

20110521 22:31:26 nbsp I adore the selection of books at the Avid Reader. I thoroughly enjoying browsing in the peaceful environment in the middle of a crazy day. Users/JennyAnnMcAllister

20110528 15:59:55 nbsp Its kind of a cool little store, seems to have a decent selection. Only thing is I am a college student and cant afford to pay list price for books right now, so I like to browse the store, then buy the books on Amazon. I would love to support a local business, provided the owner doesnt contribute money to Michelle Bachmann, as another reviewer stated  perhaps when I grow up and get a job.  Users/stevohfun

20110713 10:12:45 nbsp I love the Avid Reader and always prefer it to chain bookstores. The staff is nice and I always like the selection of books they put right in the front of the store because it has a variety of genres I wouldnt normally look at. I have bought and enjoyed several of these random books. If you ask for suggestions the staff is helpful. Support local business and go to the Avid Reader! Users/LenaSchiffer

20111229 15:34:25 nbsp F avid reader, I told them a year ago to have a copy of this book the day it was released (when they didnt have a copy of the 2nd in the trilogy the day it was released) and they didnt have it they can get it by Wed... Great thanks Users/StevenDaubert

20120123 17:45:00 nbsp It seems like a nice store.  The store had the series of books I was looking for but not the actual books in the series I needed.  I will probably give it another try if I need other books in the future. Users/LoriOrf

20120703 10:40:00 nbsp Re: earlier comments about the owner supporting Michelle Bachmann, a quick internet search reveals that she is a significant donor to the Republican Party.  See http://fundrace.huffingtonpost.com/neighbors.php?typename&lnameKnickerbocker.

20130624 20:09:31 nbsp I like the selection of books at both of the Avid Reader Bookstores however, I have not found the staff there to be particularly friendly.  I have bought books on numerous occasions and I am amazed at how unfriendly the cashiers are.  They seem annoyed to be disturbed from whatever it is they are doing to ring up a sale.  Now mind you I am not intentionally interrupting them.  I always wait until the Cashier asks if I am ready.  Given the number of independent bookstores that have gone out of business over the year you would think the staff would be trained to be friendlier.  Not that I expect to be buddies with the Cashier but I would prefer to be treated with the same level of politeness that should be given a stranger. Users/DebbieONeill

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
\ variable.f    - x4 constant and variable compilation words etc
\ -------------------------------------------------------------------------

  .( loading variable.f ) cr

\ -------------------------------------------------------------------------

  compiler definitions

\ -------------------------------------------------------------------------
\ compile new constant into dictionary

: constant      ( n1 --- )
  head,                     \ create header for new constant
  ,call doconstant          \ compile call to doconstant in new words cfa
  , reveal ;                \ compile n1 into body of constant

\ ------------------------------------------------------------------------
\ new definition for variable  - see note below

  ' constant alias var

\ -------------------------------------------------------------------------
\ new definition for constant

: const     ( n1 --- )
  create, immediate         \ create const, compile n1 into its body
  does>                     \ patch cfa of new const to do the following
    @ ?comp# ;              \ compile or return number based on state

\ var and const are my definitions for variable and constant, renamed so
\ as to not cause conflicts with existing code.  you will notice the lack
\ of the definition for 'value' which in my opinion is a very badly named
\ word which like all ans inventions totally fails to describe its
\ function.
\
\ a literal has a value.  an address has a value. a variable has a value.
\ a constant has a value.  the name "value" does not express that the
\ item in question is a VARIABLE.  Thus i call this a var.
\
\ my const definition is state smart.  if you are in compile mode
\ it will compile a literal into the : definition you are compiling.
\ if you are in interpret mode it will return the body field contents
\ as usual
\
\ !> const will work of course but doing this is heavilly frowned upon
\
\ if you ask me this is the way variable and constant should have
\ worked from day one.

\ ------------------------------------------------------------------------
\ create a new variable

: variable ( --- )
  create 0 , ;

\ ------------------------------------------------------------------------
\ compile xt2 and discard xt1 or discard xt2 and execute xt1

: (!>)    ( [ n1 xt1] | xt2 --- )
  state                     \ if we are in compile mode
  if
    nip , ' >body ,         \ discard xt1, compile xt2
  else
    drop
    >r ' >body              \ get body address of variable to modify
    r> execute              \ execute xt1
  then ;

\ ------------------------------------------------------------------------

: (?') ' >body @ ;
: ]?'  compile %?' ' >body , ;

\ ------------------------------------------------------------------------

: ?'     ( --- a1 )
  state
  ?:
    ]?' (?') ; immediate

\ ------------------------------------------------------------------------

: !>     ( | n1 --- )  ['] !    ['] %!>    (!>) ; immediate
: +!>    ( | n1 --- )  ['] +!   ['] %+!>   (!>) ; immediate
: incr>  ( --- )       ['] incr ['] %incr> (!>) ; immediate
: decr>  ( --- )       ['] decr ['] %decr> (!>) ; immediate
: on>    ( --- )       ['] on   ['] %on>   (!>) ; immediate
: off>   ( --- )       ['] off  ['] %off>  (!>) ; immediate

  ' !> alias is             \ for use on deferred words

\ ------------------------------------------------------------------------
\ there is actually a good reason to do this and its not simply about
\ insignificant improvements in compile speeds which in this forth are
\ already blazing

  0 constant 0
  1 constant 1
  2 constant 2
  3 constant 3
  4 constant 4

\ ------------------------------------------------------------------------

  forth definitions

\ ========================================================================


text:
module class_Circle

  implicit none
  private
  public :: circle_print

  real :: pi = 3.1415926535897931D0 ! module-wide private constant

  type, public :: Circle

    real :: radius ! the radius of a circle
    real :: area   ! the area of a circle
    real :: circum ! the circumference of a circle

  end type Circle

contains

!==============================================================================
! CIRCLE_AREA calculates the area of a circle
!==============================================================================

  function circle_area(this) result(area)

    type(Circle), intent(in)  :: this ! circle instance
    real                      :: area ! the area of the circle

    ! calculate the area
    area = pi * this%radius**2

  end function circle_area

!==============================================================================
! CIRCLE_CIRCUM calculate the circumference of a circle
!==============================================================================

  function circle_circum(this) result(circum)

    type(Circle), intent(in) :: this   ! circle instance
    real                     :: circum ! the circumference

    ! calculate circumference
    circum = 2*pi*this%radius

  end function circle_circum

!==============================================================================
! CIRCLE_PRINT prints information about the circle
!==============================================================================

  subroutine circle_print(this)

    type(Circle), intent(inout) :: this ! circle instance

    ! calculate area
    this%area = circle_area(this)

    ! calculate circumference
    this%circum = circle_circum(this)

    ! print results
    write(*,'("The area is:",T30,F0.4,/,"The circumference is:",T30,F0.4)')    &
   &           this%area,this%circum

  end subroutine circle_print

end module class_Circle

max_issues_repo_name: BrinedYoung/home


text:
      SUBROUTINE HUEANG (R,G,B, ANG, DIST)

C  This program calculates a characteristic angle for a hue from the
C  RGB color cube.  It does so by rotating the cube 45 deg around the
C  y-axis and atan(sqrt(2)) around the z-axis (assuming xyz = RGB).
C  This lines up the black-white cube diagonal (0,0,0 to 1,1,1) along
C  the y-axis.  Now, transformed points along the color-saturated
C  vertices are such that their angle in the x-z plane is a measure
C  of hue; so atan2 is used to compute the hue of any RGB point.

C  BTW, somewhat surprisingly, the points which are transformed into
C  the x=0 plane are all those in the old plane described by:
C  x -2y + z = 0 (this plane contains the points (0,0,0), (1,1,1),
C  and (0,.5,1), all of which can be "seen" to be rotated into x=0
C  plane).  This plane is such that it is satisfied by any points of
C  the form: (q, q+c, q+2c), so that sample points like (3,4,5) will
C  always transform into the x=0 plane.

C  Hueang also returns the distance of the RGB point from the
C  neutral (black-white) axis.

      REAL TMAT(4,4), R,G,B, XO,YO,ZO, PI,A45, ZZ,U, ANG, DIST

      ZZ = 0.0
      U = 1.0
      PI = 3.14159265
      A45 = PI/4.0

      CALL EBLTM3 (ZZ,ZZ,ZZ, ZZ,ZZ,ZZ, ZZ,A45,ATAN(SQRT(2.0)),
     1             U,U,U, TMAT)

10    CONTINUE

      CALL ETP3 (R,G,B, TMAT,  XO,YO,ZO)

      DIST = SQRT(XO*XO + ZO*ZO)

      IF (DIST .EQ. ZZ) THEN
         ANG = -666.0
      ELSE
C  Normalize to 0..1
         ANG = ATAN2(XO,ZO) / (2*PI)
         IF (ANG .LT. 0.0) ANG = ANG + 1
      ENDIF

      END


text:
C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.

C $Id: eval_hessobj_v.f,v 1.1 2002/05/02 18:52:13 andreasw Exp $
      subroutine EVAL_HESSOBJ_V(TASK, N, X, M, VIN, VOUT)
C
C     Products with Hessian of objective function for IPOPT
C     Since a linear objective function is assumed, results is always 0
C
C     Authors:  Yidong Lang, Andreas Waechter     09-29-01
C
      implicit none
      integer TASK, N, M
      double precision  VIN(N), X(N), VOUT(N)

      call DCOPY(N, 0d0, 0, VOUT, 1)
      return
      end

max_stars_repo_name: kant/CMMPPT

max_issues_repo_name: kant/CMMPPT

max_forks_repo_name: kant/CMMPPT


text:
c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   arguments.f
c   get command line arguments
c   author T. Schreiber (1998)
c===========================================================================

      subroutine argdel(i)
      parameter(margs=1000)
      dimension largs(margs)
      common /args/ nargs, largs

      if(i.eq.0) then
         nargs=min(margs,iargc())
         do 10 n=1,nargs
 10         largs(n)=1
      else
         if(i.gt.iargc()) return
         if(largs(i).eq.0) return
         largs(i)=0
         nargs=nargs-1
      endif
      end

      function nstrings()
      parameter(margs=1000)
      dimension largs(margs)
      common /args/ nargs, largs

      nstrings=max(nargs,1)
      end

      subroutine nthstring(n,string)
      parameter(margs=1000)
      dimension largs(margs)
      common /args/ nargs, largs
      character*(*) string

      iv=0
      do 10 i=1,iargc()
         if(largs(i).eq.1) iv=iv+1
 10      if(iv.eq.n) goto 1
      string="-"
      return
 1    call getarg(i,string)
      end

      function imust(c)
c get mandatory integer argument, call usage statement if missing
      character c

      imust=iopt(c,1,ierr)
      if(ierr.ne.0) call usage()
      end

      function fmust(c)
c get mandatory real argument, call usage statement if missing
      character c

      fmust=fopt(c,1,ierr)
      if(ierr.ne.0) call usage()
      end

      subroutine smust(c,string)
c get mandatory string argument, call usage statement if missing
      character c
      character*(*) string

      call sopt(c,1,string,ierr)
      if(ierr.ne.0) call usage()
      end

      function ican(c,idef)
c get optional integer argument, provide default if missing
      character c

      ican=iopt(c,1,ierr)
      if(ierr.ne.0) ican=idef
      end

      function fcan(c,fdef)
c get optional real argument, provide default if missing
      character c

      fcan=fopt(c,1,ierr)
      if(ierr.ne.0) fcan=fdef
      end

      subroutine stcan(c,string,dstring)
c get optional string argument, provide default if missing
      character c
      character*(*) string, dstring

      call sopt(c,1,string,ierr)
      if(ierr.ne.0) string=dstring
      end

      function igetout(fout,iverb)
c gets alternate output file name, default " "
c return 1 if fout must be determined from input file name
      character*(*) fout

      igetout=0
      call stcan("o",fout," ")
      if(fout.ne." ".and.nstrings().gt.1.and.iv_io(iverb).ne.0)
     .   write(istderr(),*) '*** single output file for multiple'//
     .   ' input files - results may be overwritten'
      if(fout.ne." ") return
      igetout=lopt("o",1)
      end

      subroutine imcan(c,mmax,mc,ilist)
c get optional integer argument with multiple comma separated values
      character c
      character*72 string
      dimension ilist(*)

      call stcan(c,string," ")
      string(index(string," "):index(string," "))=","
      do 10 m=1,mmax
         if(index(string,",").le.1) goto 1
         read(string(1:index(string,",")-1),*,err=1,end=1) ilist(m)
 10      string=string(index(string,",")+1:72)
 1    mc=m-1
      end

      subroutine fmcan(c,mmax,mc,flist)
c get optional real argument with multiple comma separated values
      character c
      character*72 string
      dimension flist(*)

      call stcan(c,string," ")
      string(index(string," "):index(string," "))=","
      do 10 m=1,mmax
         if(index(string,",").le.1) goto 1
         read(string(1:index(string,",")-1),*,err=1,end=1) flist(m)
 10      string=string(index(string,",")+1:72)
 1    mc=m-1
      end

max_stars_repo_name: homiak/jabaws

max_issues_repo_name: homiak/jabaws

max_forks_repo_name: homiak/jabaws


!Copyright (c) 2022 Yoshimichi ANDOH
!Released under the MIT license
!https://opensource.org/licenses/mit-license.php

!!
!! Files to be required
!! (1) ./sys_info
!! (2) ./massinfo.mdff
!! (3) *.mdmntr files  (stdin)
!!
        implicit none
!! Number of data lines in .mdmntr file
        integer(4),parameter::nline=500000
!! The Avogadro constant
        real(8),parameter :: avonum=6.0221409d+23
!! Unit conversion
        real(8),parameter :: atm=1.013d+5
!
        integer(4),allocatable :: nav(:), nmv(:)
        real(8),allocatable :: molmass(:)
        real(8),allocatable :: vmole(:), density(:), kjmol(:)
!
        integer(4) :: kom, komtot
        integer(4) :: molcount
        real(8) :: massin
        integer(4)::nfiles
        integer(4)::h,i,j,nlall
        real(8) :: datin(20)
        real(8) :: avedat(20),avedat2(20)
        real(8) :: dev(20), std(20)

!### input sysinfo ###
!! 系の分子構成ファイルの読み込み
        molcount=0
	open(21,file='sys_info',status='old')
        read(21,*) ! skip
 	read(21,*) komtot
 	allocate( nav(komtot), nmv(komtot) )
        do kom=1,komtot
          read(21,*) nav(kom),nmv(kom)
          molcount=molcount+nmv(kom)
        enddo
	close(21)

	allocate( vmole(komtot), density(komtot), kjmol(komtot) )
        allocate(molmass(komtot))

        do kom=1,komtot
          vmole(kom)=dble(nmv(kom))/avonum
          kjmol(kom)=1d0/vmole(kom)*1d-3
	enddo

!### input massinfo ###
!! 質量情報ファイルの読み込み
        open(1,file='./massinfo.mdff',status='old')
        molmass=0d0
        do kom=1,komtot
	read(1,*) ! skip <mass>
        do h=1,nav(kom)
          read(1,*) massin
          molmass(kom)=molmass(kom)+massin
        enddo
	read(1,*) ! skip </mass>
        enddo
        close(1)

        avedat=0d0
        avedat2=0d0
        nlall=0
        nfiles=0
1       continue
        read(*,*,end=99)  !! .mdmntr のヘッダーを読み飛ばす
        read(*,*)
        read(*,*)
        read(*,*)
        read(*,*)
        read(*,*)
        do i=1,nline
            read(*,*,end=99) j, datin(1:20)
!>>unit conversion
            datin(7) =datin(7) *1d+30
            datin(9) =datin(9) *1d+10
            datin(10)=datin(10)*1d+10
            datin(11)=datin(11)*1d+10
            datin(8)=datin(8)/atm
            datin(15:20)=datin(15:20)/atm
!<<unit conversion
            avedat(:)=avedat(:)+datin(:)
            avedat2(:)=avedat2(:)+datin(:)**2
            nlall=nlall+1
        enddo
        nfiles=nfiles+1
        goto 1            !! 次のファイルへ移動
99      continue

!average
        avedat=avedat/dble(nlall)
        avedat2=avedat2/dble(nlall)
        dev=avedat2-avedat**2
        std=sqrt(dev)

        do kom=1,komtot
          density(kom)=vmole(kom)*molmass(kom)/avedat(7) * 1d-6 * 1d+30
        enddo

        write(*,2) 'Tlines=',nlall
        write(*,2) 'NFiles=',nfiles
        do kom=1,komtot
          write(*,4) 'Density=',density(kom), ' [g/cm3], kom=', kom
        enddo
        write(*,3) 'Volume =',avedat(7), ' [A3]    ',  std(7)
!
        write(*,3) '|a|    =',avedat(9), ' [A]     ',   std(9)
        write(*,3) '|b|    =',avedat(10),' [A]     ',   std(10)
        write(*,3) '|c|    =',avedat(11),' [A]     ',   std(11)
        write(*,3) 'alpha  =',avedat(12),' [deg]   ', std(12)
        write(*,3) 'beta   =',avedat(13),' [deg]   ', std(13)
        write(*,3) 'gamma  =',avedat(14),' [deg]   ', std(14)
!
        write(*,3) 'Temp   =',avedat(6), ' [K]     ',   std(6)
        write(*,3) 'Press  =',avedat(8), ' [atm]   ', std(8)
        write(*,3) 'Pxx    =',avedat(15),' [atm]   ', std(15)
        write(*,3) 'Pyy    =',avedat(16),' [atm]   ', std(16)
        write(*,3) 'Pzz    =',avedat(17),' [atm]   ', std(17)
        write(*,3) 'Pxy    =',avedat(18),' [atm]   ', std(18)
        write(*,3) 'Pxz    =',avedat(19),' [atm]   ', std(19)
        write(*,3) 'Pyz    =',avedat(20),' [atm]   ', std(20)
        write(*,3) 'Pot_E  =',avedat(2)*kjmol,' [kJ/mol]',std(2)*kjmol
2       format(a,i23,a)
!3       format(a,es23.15,a,es23.15)
3       format(a,f23.6,a,f23.6)
4       format(a,f23.6,a,i5)

        stop
        end


use openacc

if (acc_get_num_devices (acc_device_host) .ne. 1) call abort
call acc_set_device_type (acc_device_host)
if (acc_get_device_type () .ne. acc_device_host) call abort
call acc_set_device_num (0, acc_device_host)
if (acc_get_device_num (acc_device_host) .ne. 0) call abort
call acc_shutdown (acc_device_host)

call acc_init (acc_device_host)
call acc_shutdown (acc_device_host)

end


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_EQK_ADV_N_DIF_Z

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY
    USE MR_DEF_TIMING

    USE MR_MOC_K_EPS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_EQK_ADV_N_DIF_Z

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_EQK_ADV_N_DIF_Z( NI , NJ , NK , EQK_ADV_Z , EQK_DIF_Z )

    USE MR_MOD_CALC_QADV_N_QDIF_Z
    USE MR_MOD_CALC_GRAD_Z

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:NK) :: EQK_ADV_Z , EQK_DIF_Z

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,0:NK) :: EQK_QADV_Z_W , EQK_QDIF_Z_W

    INTEGER(IJID_KIND) :: I , J

    CALL MR_CALC_QADV_N_QDIF_Z_SS_W( NI , NJ , NK , KI , RB , W , EQK_QADV_Z_W , EKZ/SIK , VZW , EQK_QDIF_Z_W )

  ! CALCULATE ADVECTION
    CALL MR_CALC_GRAD_Z_SS( NI , NJ , NK , EQK_QADV_Z_W , EQK_ADV_Z )

  ! CALCULATE DIFFUSION
    CALL MR_CALC_GRAD_Z_SS( NI , NJ , NK , EQK_QDIF_Z_W , EQK_DIF_Z )

  END SUBROUTINE MR_CALC_EQK_ADV_N_DIF_Z

  END MODULE MR_MOD_CALC_EQK_ADV_N_DIF_Z


text:
Margaret Roberts was appointed as City of Davis Davis City Clerk on January 17, 2006.

Prior to coming to the City of Davis, Ms. Roberts was City Clerk for the City of Rio Vista and has over 16 years of local government experience.

She currently serves as the Northern Division Professional Development Representative for the City Clerks Association of California and Vice President of the Northern California City Clerks Association.  She has served as a Northern Division board member for several years, working on a variety of issues related to city clerks and local government.


text:
!**************************************************************
!
!
! Mesh converter from cgns to nek format
!
!
!********************************************************************
!
MODULE module_global
  !
  IMPLICIT NONE
  !
  SAVE
  !
  !
  ! Select this line for DOUBLE precision of real data
  !
  INTEGER, PARAMETER :: high = 8
  INTEGER, PARAMETER :: iprec= 4
  INTEGER, PARAMETER :: single_p= 4
  !
  INTEGER(iprec) :: max_elem,energy,scalar,ifile
  !
  INTEGER(iprec), ALLOCATABLE :: index_zone(:),nbdyelem(:),sectype(:)
  INTEGER(iprec), ALLOCATABLE,DIMENSION (:) :: zonetype,index_dim,nelem_start,nelem_end
  INTEGER(iprec), ALLOCATABLE,DIMENSION (:) :: elementdatasize,tmp_Elements,tmp_ParentData, &
                  Normallist,location,bocotype,bc_fam
  INTEGER(iprec), ALLOCATABLE,DIMENSION (:,:) :: Elements,ParentData
  !
  INTEGER(iprec) :: inc,cgns_len,sec,bcsec,nbocos,nsections,ncoords,nzones,nbases,pre
  !
  REAL (high), ALLOCATABLE, DIMENSION (:) :: xv,yv,zv,xb,yb,zb
  REAL (high), ALLOCATABLE, DIMENSION (:,:) :: xf,yf,zf
  REAL (high), ALLOCATABLE, DIMENSION (:,:,:) :: vel_val
  REAL (high), ALLOCATABLE, DIMENSION (:, :) :: x_nodes
  REAL (single_p) :: version
  REAL (single_p), ALLOCATABLE, DIMENSION (:) :: xvsingle,yvsingle,zvsingle
  !
  CHARACTER (len=80) :: cgns_file,basename
  CHARACTER (len=32),ALLOCATABLE, DIMENSION (:) :: fam_name,zonename,coord_name
  CHARACTER (len=32),ALLOCATABLE,DIMENSION (:) ::sec_type,sec_name,connectname,donorname,boconame, &
                                            datasetName,BcType
  CHARACTER (len=10) :: project,ascii
  CHARACTER (len=100),ALLOCATABLE, DIMENSION (:, :) :: bc_values
  CHARACTER (len=3),ALLOCATABLE,DIMENSION (:,:) :: vel_type,tem_type,scal_type
  CHARACTER (len=32) :: bc_nek(25)
  !
END MODULE module_global

max_stars_repo_name: RonRahaman/nekRS

max_issues_repo_name: neams-th-coe/nekRS

max_forks_repo_name: neams-th-coe/nekRS


text:
!
! Copyright (c) 2015, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!

!pgi$g opt 2
subroutine contig_cpy(src, dest)
  real*4, target, contiguous :: src(:,:)
  real*4, target, contiguous :: dest(:,:)

  dest = src
end subroutine

subroutine to_1_dim(src, dest, n)
   integer :: n
   real*4 :: src(*)
   real*4 :: dest(*)
!   print *, n
!   print *, src(1:n)
   dest(1:n) = src(1:n)
!   print *, dest(1:n)
end subroutine

program p
 implicit none
 interface
  subroutine contig_cpy(a, b)
    real*4, contiguous :: a(:,:)
    real*4, contiguous :: b(:,:)
  end subroutine
 end interface

  integer, parameter :: N=4*24
  integer :: tstnbr
  integer :: rslt_sz

  real*4 :: result(N)
  real*4 :: expect(N)

  integer, parameter :: n_extent=6
  integer, parameter :: m_extent=4

  real*4, target, dimension(n_extent,m_extent) :: arr1
  real*4, target, dimension(n_extent,m_extent) :: arr2

  real*4, contiguous, pointer, dimension(:,:) :: arr1_ptr

  data arr1 /0,1,2,3,4,5,6,7,8,9,10,11,                 &
             12,13,14,15,16,17,18,19,20,22,22,23/

  data expect  /  &
       0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,22,22,23, &
       0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,22,22,23, &
       0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,22,22,23, &
       0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,22,22,23  /

  tstnbr = 1
  arr2 = 0
  call contig_cpy(arr1, arr2)
  rslt_sz = size(arr2)
  call to_1_dim(arr2, result((tstnbr-1)*rslt_sz+1:tstnbr*rslt_sz), rslt_sz)

  tstnbr = 2
  arr2 = 0
  arr1_ptr=>arr2
  call contig_cpy(arr1, arr1_ptr)
  rslt_sz = size(arr1_ptr)
  call to_1_dim(arr1_ptr, result((tstnbr-1)*rslt_sz+1:tstnbr*rslt_sz), rslt_sz)

  tstnbr = 3
  arr2 = 0
  arr1_ptr=>arr1
  arr2 = arr1_ptr
  rslt_sz = size(arr2)
  call to_1_dim(arr2, result((tstnbr-1)*rslt_sz+1:tstnbr*rslt_sz), rslt_sz)

  tstnbr = 4
  allocate(arr1_ptr(n_extent,m_extent))
  arr1_ptr = 0
  arr1_ptr = arr1
  rslt_sz = size(arr1_ptr)
  call to_1_dim(arr1_ptr, result((tstnbr-1)*rslt_sz+1:tstnbr*rslt_sz), rslt_sz)

  call check(result, expect, N)
!  print *, result

end program

max_stars_repo_name: kammerdienerb/flang

max_issues_repo_name: kammerdienerb/flang

max_forks_repo_name: kammerdienerb/flang


text:
c     ****************************************************************
c     *                                                              *
c     *                   f-90 module damage_data                    *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *              last modified : 6/28/21 rhd                     *
c     *                                                              *
c     *     define the variables and data structures to support      *
c     *     crack growth using damage parameters (e.g., the Gurson   *
c     *     model, ctoa, SMCS, etc.)                                 *
c     *                                                              *
c     ****************************************************************
c
      module damage_data
c
      parameter (mxstp_store = 10)
c
c                     arrays
c
      integer, save, allocatable :: dam_ptr(:),
     &          smcs_states_intlst(:), deleted_elist_to_stop(:),
     &          released_nlist_to_stop(:)
c
      double precision ::
     &   del_poros(mxstp_store), del_deff(mxstp_store),
     &   regular_points(10,2)
c
      integer :: user_kill_list_now(100)
c
c                     scalar double precision/reals
c
       double precision ::
     &   porosity_limit, gurson_cell_size,
     &   crack_plane_coord, release_fraction,
     &   critical_angle, release_height,
     &   crack_plane_sign, char_length,
     &   init_crit_ang,
     &   smcs_gamma, smcs_beta_1, smcs_beta_2, smcs_a_plus,
     &   smcs_a_minus, smcs_kappa, smcs_alpha_1, smcs_alpha_2,
     &   smcs_cutoff_triaxiality, max_eps_critical, smcs_type_4_A,
     &   smcs_type_4_n, smcs_type_4_c1, smcs_type_4_c2, smcs_type_4_c3,
     &   smcs_type_5_power, smcs_type_5_tp_critical, smcs_alpha,
     &   smcs_adapt_alpha_min, smcs_adapt_alpha_max,
     &   smcs_beta, control_load_fact, old_load_fact,
     &   min_load_fact, overshoot_limit, CTOA_range,
     &   perm_load_fact, max_porosity_change,
     &   max_plast_strain_change,
     &   init_ctoa_dist, ctoa_dist,
     &   crkpln_srch_tol, max_deff_change,
     &   critical_cohes_deff_fract,
     &   ppr_kill_displ_fraction, tolerance_mesh_regularization,
     &   regular_length, regular_up_max, regular_alpha,
     &   regular_Gf, regular_m_power
c
c                     scalar integers
c
      integer :: crack_growth_type,
     &   num_kill_elem, max_dam_state, csttail, num_print_list,
     &   num_kill_order_list, release_type, smcs_type,
     &   crk_pln_normal_idx, num_crack_plane_nodes, crack_front_start,
     &   crack_front_end, crkfrnt_garbage_start, crkfrnt_garbage_end,
     &   min_steps_for_release, num_nodes_thick, num_crack_fronts,
     &   num_nodes_back, num_nodes_grwinc, num_steps_min,
     &   num_elements_killed, stop_killed_elist_length,
     &   num_elements_in_force_release, num_ctoa_released_nodes,
     &   num_user_kill_elems, killed_element_limit, num_top_list,
     &   smcs_allowable_in_release, regular_type, regular_npoints,
     &   stop_released_nlist_length
c
c                     scalar logicals
c
      logical :: no_killed_elems, print_status, kill_order,
     &  kill_order_now, no_released_nodes, list_crkpln_nodes,
     &  list_crkfrnt_nodes, growth_by_kill, growth_by_release,
     &  growth_by_cohesive, enforce_node_release,
     &  overshoot_control_crk_grth, overshoot_allocated,
     &  load_size_control_crk_grth, g_stp_cntrl_allocated,
     &  const_front, master_lines_set, load_reduced, all_elems_killed,
     &  print_top_list, smcs_growth, smcs_states, smcs_stream,
     &  smcs_text, smcs_list_file_flag, use_estiff_at_death ,
     &  use_mesh_regularization
c
c                     character
c
      character(len=80) :: smcs_list_file_name
c
      end module


text:
! Copyright (c) 2017-2020, Lawrence Livermore National Security, LLC and
! other Axom Project Developers. See the top-level COPYRIGHT file for details.
!
! SPDX-License-Identifier: (BSD-3-Clause)

! Fortran code that will be inserted into code via shroud splicer blocks

! splicer begin file_top
#include "axom/config.hpp"
! splicer end file_top

! splicer begin module_use
! map conduit type names to sidre type names
use conduit, only : &
    SIDRE_NO_TYPE_ID    => CONDUIT_EMPTY_ID, &
    SIDRE_INT8_ID       => CONDUIT_INT8_ID, &
    SIDRE_INT16_ID      => CONDUIT_INT16_ID, &
    SIDRE_INT32_ID      => CONDUIT_INT32_ID, &
    SIDRE_INT64_ID      => CONDUIT_INT64_ID, &
    SIDRE_UINT8_ID      => CONDUIT_UINT8_ID, &
    SIDRE_UINT16_ID     => CONDUIT_UINT16_ID, &
    SIDRE_UINT32_ID     => CONDUIT_UINT32_ID, &
    SIDRE_UINT64_ID     => CONDUIT_UINT64_ID, &
    SIDRE_FLOAT32_ID    => CONDUIT_FLOAT32_ID, &
    SIDRE_FLOAT64_ID    => CONDUIT_FLOAT64_ID, &
    SIDRE_CHAR8_STR_ID  => CONDUIT_CHAR8_STR_ID, &
    SIDRE_INT_ID        => CONDUIT_INT_ID, &
    SIDRE_UINT_ID       => CONDUIT_UINT_ID, &
    SIDRE_LONG_ID       => CONDUIT_LONG_ID, &
    SIDRE_ULONG_ID      => CONDUIT_ULONG_ID, &
    SIDRE_FLOAT_ID      => CONDUIT_FLOAT_ID, &
    SIDRE_DOUBLE_ID     => CONDUIT_DOUBLE_ID
use, intrinsic :: iso_c_binding, only : C_INT64_T
! splicer end module_use

! splicer begin module_top
integer, parameter :: MAXNAMESIZE = 128

integer, parameter :: SIDRE_IndexType = C_INT64_T

integer, parameter :: invalid_index = -1_SIDRE_IndexType
! splicer end module_top

# SIDRE_create_fortran_allocatable_view is not in api.yaml since it is not in src/core and
# only required for the fortran interface.

! splicer begin additional_interfaces
function SIDRE_create_array_view(group, name, lname, addr, type, rank, extents) &
      result(rv) bind(C,name="SIDRE_create_array_view")
    use iso_c_binding
    import SIDRE_IndexType
    type(C_PTR), value, intent(IN)     :: group
    character(kind=C_CHAR), intent(IN) :: name(*)
    integer(C_INT), value, intent(IN)  :: lname
    type(C_PTR), value,     intent(IN) :: addr
    integer(C_INT), value, intent(IN)  :: type
    integer(C_INT), value, intent(IN)  :: rank
    integer(SIDRE_IndexType), intent(IN)  :: extents(*)
    type(C_PTR) rv
end function SIDRE_create_array_view
! splicer end additional_interfaces

max_stars_repo_name: Parqua/axom

max_issues_repo_name: Parqua/axom

max_forks_repo_name: Parqua/axom


text:
      subroutine exita(n)                                               vax750
c     implicit double precision (a-h,o-z)                                    dp
      common/bk14/lfna(15),lfnt(6)                                      vax750
	  integer::n
	  write(*,*) n
      write(lfnt(2),100) n                                              vax750
 100  format(2x,'program stop',i5)                                      vax750
c     call exit(n)                                                      nersc
      stop                                                              vax750
      end                                                               vax750

max_stars_repo_name: imohame/LabCode

max_issues_repo_name: imohame/LabCode

max_forks_repo_name: imohame/LabCode


text:
C
C	$Id: gupdvr.f,v 1.7 2008-07-27 00:21:07 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
        SUBROUTINE GUPDVR (RNVAL, IPOINT, IPRIM)
C
C  Update attribute deferral variables for a real-valued attribute.
C
C
C  Parameters:
C
C    INPUT
C      RNVAL   - New value for the attribute item.
C      IPOINT  - Pointer into deferral control variable structures,
C                and into the index array that gives the start of the
C                primitive in the attribute equivalencing array,
C                real version.
C      IPRIM   - Output primitive type associated with the attribute
C                (1=POLYLINE, 2=POLYMARKER, 3=TEXT, 4=FILL AREA).
C                used to index into other of the control variable
C                structures.
C
C      OUTPUT
C        Adjustment of attribute deferral control parameters in COMMON.
C
      include 'g01prm.h'
      include 'g01rqa.h'
      include 'g01ast.h'
      include 'g01adc.h'
C
      REAL    RNVAL(*)
      INTEGER IPOINT, IPRIM
C
      LOGICAL CHGNS
      INTEGER I, IOFF, LNGVAL
C
C  Offset and length of attribute in equivalencing structures.
C
      IOFF   = ABS(IP2AEA(IPOINT))
      LNGVAL = IL2AEA(IPOINT)
C
C  Is the new value different from the last sent?
C
      CHGNS = RNVAL(1).NE.ASAEQV(IOFF)
      DO 10 I=2,LNGVAL
        CHGNS = CHGNS.OR. RNVAL(I).NE.ASAEQV(IOFF+I-1)
   10 CONTINUE
C
      IF (CHGNS) THEN
C
C  New and last sent differ -- set aggregate change-pending parameter.
C
        AGPEND(IPRIM) = .TRUE.
      END IF
C
C  Copy new value to requested.
C
      ARAEQV(IOFF) = RNVAL(1)
      DO 30 I=2,LNGVAL
        ARAEQV(IOFF+I-1) = RNVAL(I)
   30 CONTINUE
C
C  Mark value change.
C
      VALCHG(IPOINT) = CHGNS
C
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
!
!***********************************************************************
!                                                                      *
      MODULE cons_C
!                                                                      *
!***********************************************************************
      USE vast_kind_param, ONLY:  DOUBLE
!...Created by Pacific-Sierra Research 77to90  4.3E  10:42:40   1/ 2/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      REAL(DOUBLE) :: ZERO  = 0.0D00, &
                      HALF  = 0.5D00, &
                      TENTH = 0.1D00, &
                      ONE   = 1.0D00, &
                      TWO   = 2.0D00, &
                      THREE = 3.0D00, &
                      FOUR  = 4.0D00, &
                      SEVEN = 7.0D00, &
                      TEN   =10.0D00, &
                      ELEVEN=11.0D00, &
                      EPS   = 1.0D-08
      END MODULE cons_C

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
Kirby Araullo is a candidate for ASUCD Senate in the Fall 2012 Election running on the SMART Slate.

Kirby Araullo is a History and WarPeace Studies transfer student from Cerritos, CA. He has been active in several organizations and events on campus. He won Best DocuDrama in the 2012 UC Davis Film Festival for his film Aliwa Mu Aku (Not Alone).

 Candidate Statement
 Image(keepcalmvotekirby.jpg, right)

Hey fellow Aggies! My name is Kirby Araullo (yes, like the little pink guy!) and I am running for ASUCD Senate with the SMART Slate. SMART seeks to create an inclusive environment on campus that provides a quality, culturally sensitive, comprehensive education for students of all backgrounds. I am a Senior History and WarPeace Studies transfer student from Cerritos, California. I am currently an intern for ASUCD Senator Jared CrisologoSmith, and BRIDGE: The Pilipin@ Outreach & Retention Program at the Student Recruitment & Retention Center (SRRC). I am also a volunteer at several other components of the SRRC, including SAFE (Southeast Asians Furthering Education), AIRR (American Indian Recruitment and Retention), Collective (Transfer Support Program), and, Yik’al Kuyum (the Chican@ Latin@ Holistic Support Program). I am also involved with the Asian Pacific American Leadership Committee (APALC). By serving my community in these various capacities I have had first hand experience with students from many different backgrounds and am aware of the issues they face daily.

My Platforms:

MORE TEXTBOOK RESERVES
Being in college nowadays is expensive. The heavier the books are the more painful they are for your wallets. I will work to help students save money by creating a textbook reserve located in the new Student Community Center, supplementing the Shields Library Reserves and giving students muchneeded additional study space and free access to the most common GE books.

A MORE EMPOWERED, DYNAMIC, AND SAFER UC DAVIS COMMUNITY
Safety is always an issue in every community. Many ASUCD candidates have ran for campus safety by addressing issues like more lighting and tighter security. However, many times security concerns or the feeling of being unsafe is a result of misunderstandings between students from different backgrounds. By creating a more inclusive safe space throughout our campus and nurturing greater cultural awareness among our communities I aim to help eliminate these misunderstandings.

ENSURE EQUITABLE FUNDING
I will ensure equitable and sustained support for programs benefiting student communities of all backgrounds. These are programs that aim to further the community of spirit and purpose based on mutual respect and caring as stated in our Principles of Community. These programs include, but are not limited to; Community specific graduation programs, Student of Color Conference, leadership retreats, cultural weeks, etc.

Our world today is like a crayon box in which we all come from different backgrounds. We can all choose to work individually, secluding ourselves because of differences, or work with one another by complementing and understanding each other’s similarities and differences to paint a more vibrant and inclusive community.

Be Smart! VOTE for me, KIRBY ARAULLO, #1 for ASUCD Senate and Vote SMART #25!

We aim to advocate for student rights and create a legitimate student representation on campus. :)


text:
      subroutine interlumdb(cooling_time,
     &                      wd_mass,
     &                      Z,
     &                      luminosity,
     &                      c1,
     &                      c2,
     &                      c3,
     &                      c4,
     &                      c5,
     &                      c6,
     &                      effective_temperature,
     &                      log_surface_gravity,
     &                      table)
C     Interpolating luminosity of DB WDs using cooling tables by
C     Althaus et al. (2009) for metallicities 0.001, 0.01, 0.06
C         TODO: rename
C         c1,c2,c3,c4,c5: Johnson colors Johnson (UBVRI)
      use external_types
      implicit none

C     TODO: find out the meanings of variables and rename them
      integer, parameter :: NROWB = 400,
     &                      NROWB2 = 60
      integer :: numberOfSequencesInGroup_1,
     &           numberOfSequencesInGroup_2,
     &           numberOfSequencesInGroup_3,
     &           numberOfSequences,
     &           model,
     &           modlog
      real :: cooling_time,
     &        wd_mass,
     &        Z,
     &        luminosity,
     &        effective_temperature,
     &        log_surface_gravity,
     &        Z1,
     &        lum1,
     &        teff1,
     &        logg1,
     &        Z2,
     &        lum2,
     &        teff2,
     &        logg2,
     &        c1,
     &        c2,
     &        c3,
     &        c4,
     &        c5,
     &        c6,
     &        zet1,
     &        zet2,
     &        zet3
      integer ::  vectorOfPointsNumberOfSeq_1(7),
     &            vectorOfPointsNumberOfSeq_2(9),
     &            vectorOfPointsNumberOfSeq_3(9),
     &            numberOfPointsInSequence(7)
      real :: vectorOfMasses_1(7),
     &        vectorOfPreviousTimes_1(7),
     &        matrixOfCoolingTimes_1(7,NROWB),
     &        matrixOfLuminosities_1(7,NROWB),
     &        matrixOfEffectiveTemperatures_1(7,NROWB),
     &        matrixOfLog_g_1(7,NROWB),
     &        vectorOfMasses_2(9),
     &        vectorOfPreviousTimes_2(9),
     &        matrixOfCoolingTimes_2(9,NROWB),
     &        matrixOfLuminosities_2(9,NROWB),
     &        matrixOfEffectiveTemperatures_2(9,NROWB),
     &        matrixOfLog_g_2(9,NROWB),
     &        vectorOfMasses_3(9),
     &        vectorOfPreviousTimes_3(9),
     &        matrixOfCoolingTimes_3(9,NROWB),
     &        matrixOfLuminosities_3(9,NROWB),
     &        matrixOfEffectiveTemperatures_3(9,NROWB),
     &        matrixOfLog_g_3(9,NROWB),
     &        massSequence(7),
     &        luminosityDB(7,NROWB2),
     &        colorDB_U(7,NROWB2),
     &        colorDB_B(7,NROWB2),
     &        colorDB_V(7,NROWB2),
     &        colorDB_R(7,NROWB2),
     &        colorDB_I(7,NROWB2)

      TYPE(FileGroupInfo),DIMENSION(11) :: table

C     TODO: delete this
      common /dbnums/ numberOfSequences,
     &                numberOfSequencesInGroup_1,
     &                numberOfSequencesInGroup_2,
     &                numberOfSequencesInGroup_3
      common /dbnums2/ vectorOfPointsNumberOfSeq_1,
     &                 vectorOfPointsNumberOfSeq_2,
     &                 vectorOfPointsNumberOfSeq_3,
     &                 numberOfPointsInSequence
      common /massesdb/ massSequence,
     &                  vectorOfMasses_1,
     &                  vectorOfMasses_2,
     &                  vectorOfMasses_3
      common /dbtrks1/ matrixOfLuminosities_1,
     &                 matrixOfEffectiveTemperatures_1,
     &                 matrixOfLog_g_1,
     &                 matrixOfCoolingTimes_1
      common /dbtrks2/ matrixOfLuminosities_2,
     &                 matrixOfEffectiveTemperatures_2,
     &                 matrixOfLog_g_2,
     &                 matrixOfCoolingTimes_2
      common /dbtrks3/ matrixOfLuminosities_3,
     &                 matrixOfEffectiveTemperatures_3,
     &                 matrixOfLog_g_3,
     &                 matrixOfCoolingTimes_3
      common /dbtprewd/ vectorOfPreviousTimes_1,
     &                  vectorOfPreviousTimes_2,
     &                  vectorOfPreviousTimes_3
      common /dbcolors/ luminosityDB,
     &                  colorDB_U,
     &                  colorDB_B,
     &                  colorDB_V,
     &                  colorDB_R,
     &                  colorDB_I

      zet1 = 0.001
      zet2 = 0.01
      zet3 = 0.06

C     Determinating luminosities, magnitudes for every star
      model = 0
      modlog = 0

C     Checking between what values of metallicity is the Z of input
C     calculating luminosity, effective_temperature, log_surface_gravity
C     for those values Z1 and Z2 and then interpolating for Z
      if (Z >= zet1 .and. Z < zet2) then
          Z1 = zet1
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(5)%ncol,table(5)%ntrk,
     &         table(5)%coolingTime,table(5)%prevTime,
     &         table(5)%mass,table(5)%luminosity,lum1)
          modlog = 1
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(5)%ncol,table(5)%ntrk,
     &         table(5)%coolingTime,table(5)%prevTime,
     &         table(5)%mass,table(5)%effTemp,teff1)
          modlog = 0
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(5)%ncol,table(5)%ntrk,
     &         table(5)%coolingTime,table(5)%prevTime,
     &         table(5)%mass,table(5)%gravAcc,logg1)

          Z2 = zet2
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%luminosity,lum2)
          modlog = 1
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%effTemp,teff2)
          modlog = 0
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%gravAcc,logg2)
      end if

      if (Z >= zet2 .and. Z < zet3) then
          Z1 = zet2
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%luminosity,lum1)
          modlog = 1
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%effTemp,teff1)
          modlog = 0
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%gravAcc,logg1)
          Z2 = zet3
          call interp(model,modlog,cooling_time,wd_mass,table(7)%ncol,
     &         table(7)%ntrk,table(7)%coolingTime,
     &         table(7)%prevTime,table(7)%mass,
     &         table(7)%luminosity,lum2)
          modlog = 1
          call interp(model,modlog,cooling_time,wd_mass,table(7)%ncol,
     &         table(7)%ntrk,table(7)%coolingTime,
     &         table(7)%prevTime,table(7)%mass,
     &         table(7)%effTemp,teff2)
          modlog = 0
          call interp(model,modlog,cooling_time,wd_mass,table(7)%ncol,
     &         table(7)%ntrk,table(7)%coolingTime,
     &         table(7)%prevTime,table(7)%mass,table(7)%gravAcc,
     &         logg2)
      end if

C     Interpolation 3D in function of Z
      luminosity = lum1 + (lum2 - lum1) * (Z - Z1) / (Z2 - Z1)
      effective_temperature = teff1 + (teff2 - teff1) * (Z - Z1)
     &                                / (Z2 - Z1)
      log_surface_gravity = logg1 + (logg2 - logg1) * (Z - Z1)
     &                              / (Z2 - Z1)

C     Colors interpolation, there is no metallicity here
      call intermag(wd_mass,luminosity,table(10)%ncol,
     &     table(10)%ntrk,table(10)%mass,table(10)%luminosity,
     &     table(10)%color_U,table(10)%color_B,table(10)%color_V,
     &     table(10)%color_R,table(10)%color_I,table(10)%color_J,
     &     c1,c2,c3,c4,c5,c6)
      end subroutine

max_stars_repo_name: wolvespack/alcor

max_issues_repo_name: wolvespack/alcor

max_forks_repo_name: wolvespack/alcor


text:
      subroutine runY_00lllli(k,l,i1,Xtwiddle,Gtwiddle,Shat7,N0)
      implicit none
C---  Expression for extension of Eq. 5.60b
C---  Calculates D00llli, requires D00lllll
C---  Small terms of order Xtwiddle(0,k)*Diiiiii,Xtwiddle(0,0)*Diiiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,i1,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7(np,z6max,-2:0)

      if ((i1 .eq. l) .or. (i1 .eq. 0)) then
      return
      endif

      do ep=-2,0

      Dv(dzziiiii(z5(l,l,l,l,i1))+N0,ep)=
     . (-2d0*Gtwiddle(k,i1)*Dv(dzziiiii(z5(l,l,l,l,l))+N0,ep)
     . +Gtwiddle(k,1)*Shat7(1,z6(l,l,l,l,l,i1),ep)
     . +Gtwiddle(k,2)*Shat7(2,z6(l,l,l,l,l,i1),ep)
     . +Gtwiddle(k,3)*Shat7(3,z6(l,l,l,l,l,i1),ep)
     . +Xtwiddle(k,0)*Dv(diiiiii(z6(l,l,l,l,l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Dv(diiiiiii(z7(k,l,l,l,l,l,i1))+N0,ep))
     . /(10d0*Gtwiddle(k,l))

      enddo

      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 02.01.03.03/03                        *
C  *    TEST TITLE : Effects of <change structure          *
C  *                 identifier and references> on the     *
C  *                 element pointer                       *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C edit mode
      INTEGER    PINSRT,     PREPLC
      PARAMETER (PINSRT = 0, PREPLC = 1)

C  Declare program-specific variables
      INTEGER COMSTR, ORGID, RESID

      CALL INITGL ('02.01.03.03/03')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

      CALL SETMSG ('4', 'If the original and resulting identifier '   //
     1             'are the same and the common structure is open '   //
     2             'and empty after execution of <change structure '  //
     3             'identifier and references> then the element '     //
     4             'pointer should be at zero.')

C subroutine to set up the CSS
      CALL STDCSS

      COMSTR = 142
      CALL POPST (COMSTR)
      CALL PCSTIR (COMSTR, COMSTR)
      CALL CHKELP (0)
      CALL PCLST

      CALL SETMSG ('4', 'If the original and resulting identifier '   //
     1             'are the same and the common structure is open '   //
     2             'and not empty after execution of <change '        //
     3             'structure identifier and references> then the '   //
     4             'element pointer should remain at its current '    //
     5             'position.')

C subroutine to set up the CSS
      CALL STDCSS

      CALL PSEDM (PREPLC)
      COMSTR = 111
      CALL POPST (COMSTR)

C set element pointer to 4
      CALL PSEP (4)
      CALL PCSTIR (COMSTR, COMSTR)
      CALL CHKELP (4)
      CALL PCLST

      CALL SETMSG ('5', 'If the original and resulting identifiers '  //
     1             'differ and the original structure is open after ' //
     2             'execution of <change structure identifier and '   //
     3             'references> then the open structure should be '   //
     4             'empty and the element pointer set to zero.')

C subroutine to set up the CSS
      CALL PSEDM (PINSRT)
      CALL STDCSS

      ORGID = 111
      RESID = 130
      CALL POPST (ORGID)

C  set element pointer to 3
      CALL PSEP (3)
      CALL PCSTIR (ORGID, RESID)
      CALL CHKELP (0)
      CALL PCLST

      CALL SETMSG ('6', 'If the original and resulting identifiers '  //
     1             'differ, the original structure does not exist '   //
     2             'and the resulting structure is open after '       //
     3             'execution of <change structure identifier and '   //
     4             'references> then the element pointer of the '     //
     5             'open structure should be set to zero.')

C subroutine to set up the CSS
      CALL STDCSS

      ORGID = 300
      RESID = 111
      CALL POPST  (RESID)
      CALL PCSTIR (ORGID, RESID)

      CALL CHKELP (0)
      CALL PCLST

      CALL SETMSG ('6', 'If the original and resulting identifiers '  //
     1             'differ, the original structure does exist and '   //
     2             'is empty, and the resulting structure is open '   //
     3             'after execution of <change structure identifier ' //
     4             'and references> then the element pointer of the ' //
     5             'open structure should be set to zero.')

C subroutine to set up the CSS
      CALL STDCSS

      ORGID = 142
      RESID = 111
      CALL POPST (RESID)

C  set element pointer to 2
      CALL PSEP (2)
      CALL PCSTIR (ORGID, RESID)
      CALL CHKELP (0)
      CALL PCLST

      CALL SETMSG ('6', 'If the original and resulting identifiers '  //
     1             'differ, the original structure does exist and '   //
     2             'is not empty, and the resulting structure is '    //
     3             'open after execution of <change structure '       //
     4             'identifier and references> then the element '     //
     5             'pointer of the open structure should be set to '  //
     6             'the last element.')

C subroutine to set up the CSS
      CALL STDCSS

      ORGID = 111
      RESID = 104
      CALL POPST (RESID)

C  set element pointer to 3
      CALL PSEP (3)
      CALL PCSTIR (ORGID, RESID)
      CALL CHKELP (11)

      CALL ENDIT
      END


text:
      SUBROUTINE UDS_Y_COPY( D, S )

!***********************************************************************
!* Copies UDS_Y Objects
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Headers
      INCLUDE 'uds_str.fi'

      ! Arguments ______________________________________________________

      RECORD /UDS_Y/  D ! UDS_Y object to copy to

      RECORD /UDS_Y/  S ! UDS_Y object to copy from

      ! Variables ______________________________________________________

      INTEGER I

      ! Copy specs
      CALL UDS_SPEC_COPY( D, S )

      ! Copy data
      DO I = S.NFP, S.NLP
        D.Y(I) = S.Y(I)
      END DO

      RETURN
      END

ext: for

max_stars_repo_name: DeadParrot/NHTSA-Tools

max_issues_repo_name: DeadParrot/NHTSA-Tools

max_forks_repo_name: DeadParrot/NHTSA-Tools