text:
! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE COND_NUM ( MATIN_NAME, N, KD, K_INORM, MATIN_FAC, RCOND )

! Calculatess the reciprocal of the LAPACK cond number, RCOND, of a square matrix stored in LAPACK band form.
! Uses the triangular factor of the matrix, which is called MATIN_FAC.

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, F04
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR
      USE CONSTANTS_1, ONLY           :  ZERO
      USE PARAMS, ONLY                :  ITMAX
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  COND_NUM_BEGEND
      USE LAPACK_LIN_EQN_DPB

! Interface module not needed for subr DPBCON. This is "CONTAIN'ed" in module LAPACK_LIN_EQN_DPB, which is "USE'd" above

      USE COND_NUM_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'COND_NUM'
      CHARACTER(LEN=*), INTENT(IN)    :: MATIN_NAME        ! Name of the matrix whose triang factor is input to this subr
      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: CALLED_SUBR = ' ' ! Name of a called subr (for output error purposes)
      CHARACTER( 1*BYTE), PARAMETER   :: UPLO      = 'U'   ! Indicates if matrix MATIN_FAC is an upper triangular factor

      INTEGER(LONG), INTENT(IN)       :: N                 ! No. cols in array MATIN_FAC
      INTEGER(LONG), INTENT(IN)       :: KD                ! No. of superdiagonals of KAA
      INTEGER(LONG)                   :: IWORK(N)          ! Workspace array
      INTEGER(LONG)                   :: INFO      = 0     ! Output from subr DPBCON, which calc's RCOND
                                                           ! = 0:  successful exit
                                                           ! < 0:  if INFO = -i, the i-th arg had an illegal value

      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = COND_NUM_BEGEND

      REAL(DOUBLE),  INTENT(IN)       :: K_INORM           ! The infinity-norm of the matrix whose name is MATIN_NAME
      REAL(DOUBLE),  INTENT(IN)       :: MATIN_FAC(KD+1,N) ! The upper triangular factor of the matrix whose name is MATIN_NAME
      REAL(DOUBLE),  INTENT(OUT)      :: RCOND             ! The recip of the condition number of matrix whose name is MATIN_NAME
      REAL(DOUBLE)                    :: WORK(3*N)         ! Workspace array

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Initialize outputs

      RCOND = ZERO

! Calculate recriprocal of the condition number of the stiffness matrix. Note: LAPACK subr XERBLA wrote message on illegal argument
! in a call to a LAPACK subr.

      CALL DPBCON( UPLO, N, KD, MATIN_FAC, KD+1, K_INORM, RCOND, WORK, IWORK, INFO, ITMAX, 'Y' )

      CALLED_SUBR = 'DPBCON  '
      IF      (INFO < 0) THEN                              ! LAPACK subr XERBLA should have reported error on an illegal argument
!                                                            in a call to a LAPACK subr, so we should not have gotten here
         WRITE(ERR,993) SUBR_NAME, CALLED_SUBR
         WRITE(F06,993) SUBR_NAME, CALLED_SUBR
         FATAL_ERR = FATAL_ERR + 1
         CALL OUTA_HERE ( 'Y' )                            ! Coding error, so quit

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 3501 FORMAT(' *INFORMATION: RECIPROCAL OF THE CONDITION NUMBER OF THE ',A,' MATRIX IS RCOND   = ',1ES13.6,                        &
                           ' Used for LAPACK error estimate, below',/)

  993 FORMAT(' *ERROR   993: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' LAPACK SUBR XERBLA SHOULD HAVE REPORTED AN ERROR ON AN ILLEGAL ARGUMENT IN A CALL TO LAPACK SUBR '    &
                    ,/,15X,A,' (OR A SUBR CALLED BY IT) AND THEN ABORTED')

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

      END SUBROUTINE COND_NUM

max_stars_repo_name: luzpaz/MYSTRAN

max_issues_repo_name: luzpaz/MYSTRAN

max_forks_repo_name: luzpaz/MYSTRAN


text:
! test.f90
module mymodule
use, intrinsic :: iso_fortran_env, only: real64
contains
subroutine eikR(a,k,n,M)
    implicit none

    integer,            intent(in)    :: n
    real(real64),       intent(in)    :: a(n)
    complex(real64),    intent(in)    :: k
    complex(real64),    intent(out)   :: M(n,n)

    ! Local
    integer                         :: i, j
    real(real64)  :: rtmp(n), sinp(n), cosp(n), tmp_exp(n)
    real(real64)  :: itmp(n), a_pow_2(n)

    complex(real64) :: imk
    real(real64) :: rimk
    real(real64) :: iimk, tmp

    imk = (0,1) * k
    rimk = real(imk)
    iimk = imag(imk)

    a_pow_2 = a * a

    !$OMP PARALLEL DO DEFAULT(private) SHARED(a_pow_2, M, n, rimk,iimk)
    do j=1,n

    rtmp = a_pow_2 + a_pow_2(j)
    call vdsqrt(n, rtmp, rtmp)

    ! real part
    call vdexp(n, rimk * rtmp, tmp_exp)

    ! imag part
    call vdsincos(n, iimk * rtmp, sinp, cosp)

    ! assemble output
    M(:, j) = cmplx(tmp_exp * cosp, tmp_exp * sinp)
    end do
    !$OMP END PARALLEL DO

end subroutine eikR
end module

program test
use, intrinsic :: iso_fortran_env, only: real64
use mymodule
use omp_lib
real(real64), parameter :: pi = 4*atan(1.0)
integer :: i, j, n
real(real64), allocatable :: a(:)
complex(real64) :: k
complex(real64), allocatable :: m(:, :)
real(real64) :: t1, t2
do i = 1, 10
   t1 = omp_get_wtime()
   n = 1000*i
   if(allocated(m)) deallocate(m)
   allocate(m(n, n))
   a = [(2*j*pi/(n - 1), j=0, n - 1)]
   k = cmplx(100.0, 1.0)
   call eikr(a, k, n, m)
   t2 = omp_get_wtime()
   print *, n, t2 - t1, 'seconds'
enddo
end program

max_stars_repo_name: mdmaas/julia-numpy-fortran-test

max_issues_repo_name: mdmaas/julia-numpy-fortran-test

max_forks_repo_name: mdmaas/julia-numpy-fortran-test


text: blacklist \n test

ext: f


text:
!----------------------------------------------------------------------
!-------Analisys settings ---------------------------------------------
!----------------------------------------------------------------------

ANTYPE,2 ! 2 = modal

Modes = 25

LoadSteps = 1 !Make sure to do only one simulation.

MODOPT,LANB,Modes
EQSLV,SPAR
MXPAND,Modes, , ,1
LUMPM,0
PSTRES,0

MODOPT,LANB,Modes,0,0, ,OFF

NCNV,1,0,0,18000,0 !Stop simulation after x seconds

/NOPR
KEYW,PR_SET,1
KEYW,PR_STRUC,1
KEYW,PR_THERM,0
KEYW,PR_FLUID,0
KEYW,PR_ELMAG,0
KEYW,MAGNOD,0
KEYW,MAGEDG,0
KEYW,MAGHFE,0
KEYW,MAGELC,0
KEYW,PR_MULTI,0
/GO

TREF,  0.00000000
IRLF,  0
BFUNIF,TEMP,_TINY
ACEL,  0.00000000    ,  0.00000000    ,  0.00000000
OMEGA,  0.00000000    ,  0.00000000    ,  0.00000000
DOMEGA,  0.00000000    ,  0.00000000    ,  0.00000000
CGLOC,  0.00000000    ,  0.00000000    ,  0.00000000
CGOMEGA,  0.00000000    ,  0.00000000    ,  0.00000000
DCGOMG,  0.00000000    ,  0.00000000    ,  0.00000000

DELTIM, 0.500000000    , 0.200000000    , 0.500000000    , !Timesteps
KUSE,     0
ALPHAD,  0.00000000
BETAD,  0.00000000
DMPRAT,  0.00000000
DMPSTR,  0.00000000

CRPLIM, 0.100000000    ,   0
CRPLIM,  0.00000000    ,   1
NCNV,     1,  0.00000000    ,     0,  0.00000000    ,  0.00000000

NEQIT,     0

ERESX,DEFA

max_stars_repo_name: dryjognos/AnsysSleeperModel

max_issues_repo_name: dryjognos/AnsysSleeperModel

max_forks_repo_name: dryjognos/AnsysSleeperModel


text:
module psy_layer
contains
subroutine psy(a)
  use field_mod, only : field
  implicit none
  type(field) :: a

  call psy_target(a%data)

end subroutine psy
end module psy_layer

max_stars_repo_name: stfc/PSycloneBench

max_issues_repo_name: stfc/PSycloneBench

max_forks_repo_name: stfc/PSycloneBench


text:
The Emma Goldman Institute for Anarchist Studies is an art project started by UC Davis Masters of Fine Arts student Users/SteveLambert Steve Lambert. The piece of art that bears the title wiki:wikipedia:Emma_Goldman Emma Goldman Institute for Anarchist Studies is a sign mimicking the design of the university construction signs.  It is ten feet by seven feet and made of wood, inkjet, and vinyl. It was on display at the Pence Gallery in June of 2005.  The sign was also http://www.livejournal.com/community/ucdavis/2215306.html spotted on the Art Buildings lawn on May 27th, 2005, where it sat next to some University Construction ongoing construction. It was most recently seen on the grass by Environmental Horticulture on September 27th, 2005. A good crowd of people were stopping to read it  and presumably trying to decide if it is real or not. It is a real sign, no doubt.

While the web address (ucdavis.egias.org) on the sign looks like a http://www.ucdavis.edu ucdavis.edu web page, and might once have routed to a website that continued the facade, it seems that ownership of the egias.org domain has lapsed, and has been taken over by a softcore porn vendor.
Or perhaps this is just another stage of the ironic commentary of this satire?

 More information

  A California Aggie article dated October 17, 2005, titled Unusual Art Piece Utilizes Power of Signs (link expired, unfortunately)
  http://www.newsreview.com/sacramento/Content?oidoid%3A46065 Sacramento News & Review Article
  The http://ucdavismagazine.ucdavis.edu/issues/win06/end_notes.html Winter 2006 issue of UC Davis Magazine featured a halfpage article (w/pic) on this sign.
  From the 0130:0205 issue of the weekly OGS newsletter GradLink:
            Steve Lambert (Art), while engaged in activities related to his “AntiAdvertising Agency” in San Francisco, installed a sign announcing the planned construction of the Emma Goldman Institute of Anarchist Studies in a field south of the Arboretum in the fall.
  Detailed, stepbystep instructions on how the sign was made on http://www.instructables.com/id/LookLikeYourEnemyCreatesignsthatconfusea/ Instructables  Steve
  http://visitsteve.com/made/emma/ Steve Lamberts own page about the sign  Has another description from the artist.
  Heres an image of the type of sign this sign was mocking  this one was for the Robert Mondavi Institute for Wine and Food Science:
    http://daviswiki.org/Robert_Mondavi_Institute_for_Wine_and_Food_Science?sendfiletrue&filesignwinefood.jpg

 More Images

20050930 15:58:12 nbsp Hail wiki:WikiPedia:Eris Eris! Users/BrentLaabs

20051017 08:37:10 nbsp I love this sign! Users/JackHaskel

20051108 02:09:58 nbsp I was bikeriding to the Mondavi Center and when I saw this sign, I freaked out. First, I was really curious about why UC Davis would dedicate a whole institute to the study of anarchy, and second, this is a government funded institute so anarchy studies seem terribly ironic. Also, myself and a friend of mine were talking about Emma Goldman, so the sign definitely caught my attention. And when I heard from a friend that the sign was fake, that it was set up by an art student, I thought, Kudos to him! Thats a damn awesome sign. It sure as hell fooled me!!! Users/ArielaHaro

20051108 08:36:32 nbsp Got me! I, too thought this was for real and thought Oh those wacky academics. Users/PaulThober

20051108 19:40:48 nbsp When I saw it I thought Damn good idea! (though the cost seemed high by 100x). Historically there was a major Jewish Anarchist movement, they had their own schools even. I saw a documentary on it. It is more appropriate than you might think... Users/SteveDavison

20051119 15:59:16 nbsp Hilarious.  Im pleasantly surprised that The Man hasnt taken action against the posting of this sign  maybe free speech is making a comeback. Users/GrahamFreeman

20060119 19:09:28 nbsp Dammit...We need a real anarchist institute. Users/TobinJones

20060124 23:47:15 nbsp By all means, feel free to make your own Anarchist Institute at UC Davis.  You certainly dont need a multimillion dollar building or offficial approval to get something started.  Do it yourself!  Step one, team up with the Anarchist Reading Group.  Users/SteveLambert

20060124 23:57:35 nbsp Yeah, isnt a statefunded and approved Anarchist Institute a bit of a contradiction? :) Users/RoyWright
  I think that was the jokeUsers/TobinJones

20070301 21:17:41 nbsp Actually, San Francisco City College houses the lagest Anarchist Library around, from what I remember. Users/KennethSime

20070722 20:49:13 nbsp Kenneth, UC Davis has an Anarchist Papers Special Collection in the library.  UC Berkeley is home of the Emma Goldman Papers Project.  Not sure about SF State... Users/slambert

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
Putah Creek is the primary drainage for the UC Davis campus, forming a not so vital link in the hydrological cycle between mountain and sea, but a very vital link between mountain runoff and farmers. The portion of Putah Creek moving through UC Davis is the lowermost reach of a creek that drains a large watershed originating in springs on Cobb Mountain. Putah Creek flows through Middletown and eventually empties into Lake Berryessa Berryessa Reservoir. Below the Putah Creek Diversion Dam, Putah Creek is diverted for use in Solano County and UC Davis before flowing through a leveecontrolled channel past Winters, south of Davis and terminating in the toe drain of the Yolo Bypass. Lower Putah Creek, which once supported over 22,000 acres of lush riparian forest, has been modified over the years into a regulated stream following an unnatural channel and supporting many introduced species of plants and animals. Putah Creeks main channel was historically its north fork, which runs through campus (the present day UC Davis Arboretum). For flood control, the Army Corps of Engineers diverted all of the flow to the south fork, which is obviously the new main channel.

Despite its concrete walls, the Putah Creek channel passing through the UC Davis Arboretum enhances the beauty of campus. As the channel widens in front of Mrak Hall, it is called Lake Spafford Spafford Lake  every few years, this section of the channel is drained for cleaning, and many stolen bicycles are recovered. All storm water runoff from the UCD campus ends up in the Arboretum. The new UC Davis Waste Water Treatment Plant discharges its effluent into the south branch of Putah Creek, just west of Old Davis Road. Moving across to the west of Highway 113 the original creek channel appears as a depression wandering through Spieth Reserve.

The Putah Creek Council is probably the most important localissue Environmental Organizations Environmental Organization. For more information on the history of Putah Creek, see http://bioregion.ucdavis.edu The PutahCache Bioregion Website.

In 2008, http://www.sacbee.com/378/story/1267438.html the state of California fined UC Davis $78,000 for pumping too much pollution into the creek from its campus sewage treatment plant.

 History
The original name for the creek, as given by the local Native Americans who once lived beside it, sounded something like Liwaito or Leywe according to 19th century texts written by people of limited familiarity with the Patwin language.

Putah descends from Puto, which is the name that the Spanish settlers gave to the local Native American tribe. The Spanish name for the creek was therefore Rio de los Putos, meaning River of the Putos. Due to the fact that puta and puto in Spanish mean female whore and male whore, there has been much speculation over whether or not these names were meant to be intentionally offensive. The Native American tribe in question referred to themselves using a word which sounded something like Puttoy to the European settlers ears; therefore Puto may or may not have represented an honest but unfortunate attempt to transliterate the original term to Spanish.

For some reason, the local people decided to shorten the name and change Puto to the feminine form of the noun around 1845. However, the United States Board on Geographic Names found Puta obscene, and therefore the h was placed at the end.

Putah Creek Winery cites on their website the less controversial derivation found in California Place Names (Gudde, 1949) which claims that Putah mean grassy creek in native Miwok.

At one point the people who lived here harvested wiki:wikipedia:Tule reeds that they used to build Tule House tule houses.

In its early years, Town History Davisville was periodically flooded by high flows from Putah Creek and by 1872 efforts began to divert Putah Creek away from the city. A new channel, the south fork, was dredged and is the channel we now know as Putah Creek as it passes the southern periphery of the UC Davis campus. The concrete levees on both sides of the creek bed result from this dredging, which was expanded by the Army Corps of Engineers over the course of 19431949. The channel straightening caused Putah Creek to cut downward, leaving a channel 1020 feet lower than the original stream bed. When Monticello Dam began operation in 1957, the downcutting ended with flood waters being stored in lake Berryessa. Though the cementlined canal meandering through the Arboretum, the Arboretum Waterway, follows the original creek bed, it has no natural flow and acts more like a EPA Superfund area pond than a creek.

During the 19871992 drought, the south fork nearly dried up several times, when flow from Monticello Dam and Berryessa Reservoir to the channel was cut off by the Solano Irrigation District. During this period, water in the Arboretum Waterway was maintained solely by effluent from UC Davis aquaculture facilities and the sewage treatment plant. Flows were reluctantly restored only after the Putah Creek Council got involved and, with the assistance of the university and Alhambra Water, actually purchased water to keep the creek alive. This situation resulted in a lawsuit filed by the Putah Creek Council, the City of Davis and the university. The creek was awarded additional water flows but the decision has been appealed and the battle to keep Putah wet continues.

See also http://www.putahcreek.org/ Putah Creek Coordinating Committee

 Recreation
Putah Creek is a wonderful and close place to spend some time outdoors. There is decent bass fishing and great carp fishing in the section of creek from the UC Davis Putah Creek Picnic Area Picnic Area downstream to the stillwater below Old Davis Road. The band wiki:WikiPedia:Creedence_Clearwater_Revival Creedence Clearwater Revival even wrote the song Green River about spending their summers at Putah Creek.

 Swimming
Good swimming spots exist wherever waters are deep enough to swim.  Many cyclists enjoy plunging into the cold waters of the Winters Swimming Hole after making the 14mile ride.  This swimming hole benefits from a rope swing which hangs from a large creekside sycamore tree and plenty of spots for sun bathing on a defunct concrete dam.  Those less inclined to make the trip to Winters can find slightlywarmer, but still refreshing, spots to swim within the http://putahcreek.ucdavis.edu/ UC Davis Riparian Reserve.

The water of lower Putah Creek is clearest in the spring and early summer.  The late summer buildup of algae and vascular plants earned Putah Creek the song title Green River by members of Creedence Clearwater who enjoyed swimming in the creek.

 Hiking and Backpacking Trails
A majority of the northern levee of Putah Creek is open to the public for walking, running, or bicycling.  Closer to the creek, trails within the Putah Creek Riparian Reserve are great for hikers, walkers  and joggers.  While in the Riparian Reserve remember to watch out for poison oak and be advised that bikes are not allowed and dogs must be onleash.

 Town Wildlife Wildlife & Bird Watching
The riparian reserve is an excellent place to see some of the more worthwhile town wildlife. Birds Bird watching is quite good, as the riparian vegetation is an oasis for birds in a sea of treeless ag and urban lands. In spring, California State Endangered Swainsons Hawks use the creeks large trees for nesting.  River Otters and Beavers can be spotted on the banks of the creek. The Arboretum is also great place to see ducks Sex copulate.  It is worth noting that many of the Weeds weedy banks surrounding the river are known for Ticks.

 Fishing
There is decent bass fishing and great carp fishing in the http://www.yolocounty.org/index.aspx?page387 section of creek down to the UC Davis Picnic Area and the stillwater below Old Davis Road. Upstream from http://www.fishsniffer.com/maps/putah.html Lake Solano up to Lake Berryessa is a great wild and hatchery raised trout fishery.http://www.putahcreekflyfishing.com/ Greg Bonovich is a flyfishing guide on Putah Creek.

 Boating

There are three distinct sections for http://brtinsights.blogspot.com/2009/08/putahcreekpaddleboatingcalifornia.html paddleboating on Putah Creek:
 Upstream from Lake Berryessa  class IV+ whitewater  beware strainer hazards. This section begins just south from Clear Lake.
 Lake Berryessa outflow to Lake Solano County Park  class II whitewater  beware strainer hazards. This short section is east of Winters.
 Lake Solano outflow to Sacramento River  class I flatwater. This section flows south of Winters and south of Davis via Stevenson Bridge, Old Davis Road bridge & Mace Boulevard bridge.

A popular boating trip done by many Davis youth whom have participated in Camp Putah starts from the picnic area at Putah Creek Riparian Reserve. This trip takes the boater about 1015 minutes downstream on flat water to the rapids. At a sharp right bend in the river, get out and walk or float downstream. The water here is usually about 13 feet deep and somewhat swiftly moving. About 75 feet after the bend the river takes another sharp turn to the left and takes all who are floating through bushes that form a tunnel over the river. It is easy to get back on your feet and do the tunnel as many times as you want. There are some good blackberry bushes on this section as well.

Several items below should be noted.
 1. Dont spread http://daviswiki.org/Lake_Solano_County_Park?actionFiles&doview&targetnew_zealand_mudsnails.JPG New Zealand mud snails from Putah Creek to other waterways!
 1. Boating on our navigable waterways is the right of any person in the United States, but you should probably be aware of the risks.  Putah Creek is untamed and contains many strainers and blind rapids. http://waterdata.usgs.gov/nwis/dv/?site_no11454000&PARAmeter_cd00060 Flow is not constant, and subject to change.
 2. There are many blind corners, most of which are left handed. In fact an oddly high percentage of them are left handed.
 1. Depending on the time of year you may have to navigate through sections where the water flows under a surface logjam of trash and debris. Think the garbage compactor from Star Wars to get an idea of what that is like.
 1. The river will pull you through every blackberry bush it can. There is a lot of overhanging foliage ranging from trees that act as strainers to bushes with thorns.
 1. The narrowest stretch is between Interstate 80 I80 and Old Davis Road.
 1. There is at least one place where there is a large log just above the water. There are several areas that require a portage.
 1. It takes all day, pack a lunch and wear your Sun Protection sunscreen.
 1. All of these notes are subject to changes by Mother Nature.

 Climbing
 Check out the Putah Creek Boulders.

 Links
  http://delicious.com/brthomas/PutahCreek Putah Creek Recreation & Conservation Directory Display options: alphabetical 100. Section 1kayakingcanoeing, 3conservation, 4fishing, 5hikingcamping, 6local information.
  http://putahcreek.ucdavis.edu UC Davis Putah Creek Riparian Reserve web site
  http://bioregion.ucdavis.edu/what/restoria.html The PutahCache Bioregion Project

20081008 17:34:59 nbsp The creek that runs through UC Davis is really ugly in my opinion, though the surroundings are awesome. Why dont they turn it back into a running creek? It seems like some running water would make it look so much better. Users/TimJ

20101025 09:42:52 nbsp you should do something about it. Users/DeanMcVey

20110820 03:39:36 nbsp yea do something about it. Users/MikeyCrews

20110820 09:14:12 nbsp Do volunteer work for the Putah Creek Council! Users/CovertProfessor

20120209 18:46:16 nbsp I saw some sort of mammal swimming in the creek today. It didnt swim like an otter. It swam like a beaver, but seemed to small to be a beaver and I didnt see a big tail. Somewhere between a large rat and beaver in shape and appearance. I posted a picture of it above, though its very small in the photo. It went beneath the surface when I approached. Any thoughts as to what that could be? Users/MikeyCrews

20120209 21:30:18 nbsp Prolly a muskrat. Ive seen them by and in the creek over the years. Users/CarlosOverstreet


text:
program memleak
  implicit none

  call foo()

contains

  subroutine foo
    integer, dimension(:), pointer :: x

    allocate(x(10))

    x(11) = 0         ! heap block overrun
    return            ! x not deallocated
  end subroutine foo

end program memleak

max_stars_repo_name: jrblevin/scicomp

max_issues_repo_name: jrblevin/scicomp

max_forks_repo_name: jrblevin/scicomp


text:
program main
!==================================================================================
! Main program for testing the radiative transfer module
!==================================================================================

use radiation_mod

implicit none

real                :: pg0     = 1.0
real                :: zy      = 60.0
real                :: surfalb = 0.30
real                :: fco2, pco2, ptot, olr, palb, tg0
real, dimension(28) :: pco2levels

integer             :: temp, tstart=190, tend=370, tstep=1
integer             :: i

pco2levels = (/ 1.e-6,3.e-6,6.e-6,1.e-5, 3.e-5, 6.e-5,1.e-4, &
3.e-4, 6.e-4,1.e-3, 3.e-3, 6.e-3,1.e-2, 3.e-2, 6.e-2,1.e-1,  &
3.e-1, 6.e-1,1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)

call radiation_init

do temp = tstart, tend, tstep
  do i = 1, 28

    pco2 = pco2levels(i)

    ptot = pg0 + pco2
    fco2 = pco2 / ptot

    tg0 = real( temp )

    call getOLR( fco2, tg0, olr )
    !print *, olr / 1000.

    call getPALB( fco2, tg0, zy, surfalb, palb )
    print *, palb

  end do

end do

call radiation_end

end program main

max_stars_repo_name: BlueMarbleSpace/hextor

max_issues_repo_name: BlueMarbleSpace/hextor

max_forks_repo_name: BlueMarbleSpace/hextor


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

      SUBROUTINE DONRM3 (COORD, LTNESS, MAP, DIRCOS, TEMP,
     *    NSEG, NUMNIQ, NUMNP)
      DIMENSION COORD(NUMNP, *), LTNESS(4,*), MAP(*), DIRCOS(5,*),
     *    TEMP(3,*)

      DO 10 ISEG = 1, NSEG
          XI = COORD(LTNESS(1,ISEG),1 )
          YI = COORD(LTNESS(1,ISEG),2 )
          ZI = COORD(LTNESS(1,ISEG),3 )

          XJ = COORD(LTNESS(2,ISEG),1 )
          YJ = COORD(LTNESS(2,ISEG),2 )
          ZJ = COORD(LTNESS(2,ISEG),3 )

          XK = COORD(LTNESS(3,ISEG),1 )
          YK = COORD(LTNESS(3,ISEG),2 )
          ZK = COORD(LTNESS(3,ISEG),3 )

          XL = COORD(LTNESS(4,ISEG),1 )
          YL = COORD(LTNESS(4,ISEG),2 )
          ZL = COORD(LTNESS(4,ISEG),3 )

          AI =  (YK - YI) * (ZL - ZJ) - (ZK - ZI) * (YL - YJ)
          BJ =  (ZK - ZI) * (XL - XJ) - (XK - XI) * (ZL - ZJ)
          CK =  (XK - XI) * (YL - YJ) - (YK - YI) * (XL - XJ)
          RMAG = SQRT ( AI**2 + BJ**2 + CK**2)

          TEMP(1,ISEG) = AI / RMAG
          TEMP(2,ISEG) = BJ / RMAG
          TEMP(3,ISEG) = CK / RMAG

   10 CONTINUE

      DO 20 I=1,NUMNIQ
          DIRCOS(1,I) = 0.0
          DIRCOS(2,I) = 0.0
          DIRCOS(3,I) = 0.0
   20 CONTINUE

      DO 40 ISEG = 1, NSEG
          DO 30 J = 1, 4
              MISEG = MAP( 4 * (ISEG-1) + J )
              DIRCOS(1,MISEG) = DIRCOS(1,MISEG) + TEMP(1,ISEG)
              DIRCOS(2,MISEG) = DIRCOS(2,MISEG) + TEMP(2,ISEG)
              DIRCOS(3,MISEG) = DIRCOS(3,MISEG) + TEMP(3,ISEG)
   30     CONTINUE
   40 CONTINUE

C ... NORMALIZE ALL DIRECTION COSINES

      DO 50 I = 1, NUMNIQ
          A = DIRCOS(1,I)
          B = DIRCOS(2,I)
          C = DIRCOS(3,I)
          R = SQRT(A**2 + B**2 + C**2)
          DIRCOS(1,I) = A/R
          DIRCOS(2,I) = B/R
          DIRCOS(3,I) = C/R
   50 CONTINUE
      RETURN
      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
      subroutine expression

      byte         b

      character     c
      character*7   c7

      integer      i
      integer*2    i2
      integer*4    i4
      integer*8    i8

      logical      l
      logical*1    l1
      logical*2    l2
      logical*4    l4
      logical*8    l8

      real         r
      real*4       r4
      real*8       r8
      double precision  dp

      complex      comp
      complex*8    comp8
      complex*16   comp16
      double complex dcomp

C     test types of the RHS expressions

C     Unary Expressions
      u1 = +i
      u2 = -i
      u3 = +r
      u4 = -r
      u5 = .NOT. l
      u6 = .NOT. .TRUE.

C     Arithmetic Expressions - Type Promotion
C     different kind of integers
      a1  = i + i2   ! int 4
      a2  = i - i4   ! int 4
      a3  = i * i8   ! int 8
      a4  = i8 / i2  ! int 8
      a5  = i8 ** i4 ! int 8

C     integer and logical
      a6  = i + l    ! int 4
      a7  = i2 + l   ! int 4
      a8  = i + l1   ! int 4
      a9  = l8 + i   ! int 8

C     integer and real
      a10 = i + r    ! real 4
      a11 = r + r8   ! real 8
      a12 = i + r8   ! real 8
      a13 = r + dp   ! real 8
      a14 = dp + r   ! real 8
      a15 = l + r8   ! real 8
      a16 = dp - i   ! real 8
      a17 = r + i8   ! real 4, even integer is 8 bytes

c     complex with integer and real
      a18 = comp + i      ! comp 8
      a19 = comp - r      ! comp 8
      a20 = comp16 * i    ! comp 16
      a21 = dcomp / comp  ! comp 16

C     String Concatenation
      s1 = c // c7   ! char 8
      s2 = c7 // c   ! char 8

C     Relational Expression
      re1 = i .LT. i8  ! logical 4
      re2 = r .GT. i8  ! logical 4
      re3 = r .EQ. r4  ! logical 4
      re4 = i .NE. i4  ! logical 4
      re5 = r8 .LE. r4 ! logical 4
      re6 = r .GE. i   ! logical 4

C     Logical Expression
      le1 = l .AND. l2    ! logical 4
      le2 = i8 .OR. l     ! logical 8
      le3 = l1 .XOR. l2   ! logical 2
      le4 = l1 .EQV. l2   ! logical 2
      le5 = l  .NEQV. l2  ! logical 4

C     More expressions
      e1 = 42 * i8 - i4             ! int 8
      e2 = 42 + len(c // c7)        ! int 4
      e3 = (1, 2) + (i8 - 12.34)    ! complex 8
      e4 = i .GT. 42 .AND. i .LE. r ! Logical 4
      e5 = int(r) + z'1f' * 2       ! Int 4

      end

max_stars_repo_name: camfort/fortran-vars

max_issues_repo_name: camfort/fortran-vars

max_forks_repo_name: camfort/fortran-vars


text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  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.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      SUBROUTINE MESTOK ( LUNUT  , LUNIN  , LUNINC , LINE   , IPOSL  ,
     *                    IPOSR  , IWIDTH , LINERR , ITYPEX , ITYPE  ,
     *                                               LINENO , IERR   )
C
C     Deltares     SECTOR WATERRESOURCES AND ENVIRONMENT
C
C     CREATED: may  - 1996 by L. Postma
C
C     FUNCTION            : Produces an error message
C
C     LOGICAL UNITNUMBERS : LUNUT - output file for the message
C
C     SUBROUTINES CALLED  : none
C
C     PARAMETERS          :
C
C     NAME    KIND     LENGTH     FUNCT.  DESCRIPTION
C     ----    -----    ------     ------- -----------
C     LUNUT   INTEGER       1     INPUT   logical unitnumber output file
C     LUNIN   INTEGER       1     INPUT   unit number in error
C     LUNINC  CHAR*(*)      1     INPUT   file name of unit in error
C     LINE    CHAR*(*)      1     INPUT   line read on unit in error
C     IPOSL   INTEGER       1     INPUT   left position token on error
C     IPOSR   INTEGER       1     INPUT   right position token on error
C     IWIDTH  INTEGER       1     INPUT   total width of the input line
C     LINERR  CHAR*(*)      1     INPUT   text string to produce as error
C     ITYPEX  INTEGER       1     INPUT   type of token expected
C     ITYPE   INTEGER       1     INPUT   type of token found
C     LINENO  INTEGER       1     INPUT   current line in the file
C     IERR    INTEGER       1     INPUT   error number returned from read
C
C
      CHARACTER*(*) LUNINC, LINE, LINERR
      CHARACTER     LINE2*80, CCHAR*10 , CINT*8, CREAL*5
      DATA   CCHAR / 'character '/ ,
     *       CINT  / 'integer '  / ,
     *       CREAL / 'real '     /
C
      WRITE ( LUNUT , * )
C
C         File information when LUNIN unequal to 0
C
      IF ( LUNIN .NE. 0 ) THEN
         IF ( LUNINC .NE. ' ' ) THEN
            WRITE ( LUNUT , 1000 ) LUNIN, LUNINC
         ELSE
            WRITE ( LUNUT , 1010 ) LUNIN
         ENDIF
      ENDIF
C
C         Line information when line is not blank
C
      IF ( LINE .NE. ' ' ) THEN
         WRITE ( LUNUT , 1020 ) LINENO, ' '
         IF ( IPOSL .NE. 0 .AND. IPOSR .NE. 0 ) THEN
            IWIDTH_TRIM = LEN_TRIM(LINE)
            DO 20 J = 1 , IWIDTH_TRIM , 80
               WRITE ( LUNUT , '(A)' ) LINE (J:MIN(J+79,IWIDTH_TRIM))
               LINE2 = ' '
               IF ( IPOSL-J .LT. 80 ) THEN
                  ILIM = IPOSR
                  IF ( ITYPE .EQ. -1 ) ILIM = ILIM-1
                  DO 10 I = MAX(IPOSL-J+1,1), MIN(ILIM-J+1,80)
                     LINE2(I:I) = '^'
   10             CONTINUE
               ENDIF
               WRITE ( LUNUT , '(A)' ) LINE2
   20       CONTINUE
         ENDIF
      ENDIF
C
C         Error code ?
C
      IF ( IERR .NE. 0 ) WRITE ( LUNUT , 1030 ) IERR
C
C         You can't always get what you want
C
      IF ( ITYPEX .EQ. 1 ) WRITE ( LUNUT , 1040 ) CCHAR
      IF ( ITYPEX .EQ. 2 ) WRITE ( LUNUT , 1050 ) CINT
      IF ( ITYPEX .EQ. 3 ) WRITE ( LUNUT , 1040 ) CREAL
      IF ( ITYPE  .EQ. 1 .OR. ITYPE .EQ. -1 )
     *                     WRITE ( LUNUT , 1060 ) CCHAR
      IF ( ITYPE  .EQ. 2 ) WRITE ( LUNUT , 1070 ) CINT
      IF ( ITYPE  .EQ. 3 ) WRITE ( LUNUT , 1060 ) CREAL
      IF ( ITYPEX .LT. 0 ) WRITE ( LUNUT , 1080 )
C
C         Something else to say ?
C
      IF ( LINERR .NE. ' ' ) WRITE ( LUNUT , '(A)' ) LINERR
C
      RETURN
C
C         Formats
C
 1000 FORMAT ( ' ERROR reading file on unit:',I4,', filename: ',A )
 1010 FORMAT ( ' ERROR reading file on unit:',I4,' !' )
 1020 FORMAT ( ' Line on input file was (at line no. ', I0, '):', A )
 1030 FORMAT ( ' Error code from input processor was: ',I2 )
 1040 FORMAT ( ' Expected was a ',A,'!' )
 1050 FORMAT ( ' Expected was an ',A,'!' )
 1060 FORMAT ( ' Detected was a ',A,'!' )
 1070 FORMAT ( ' Detected was an ',A,'!' )
 1080 FORMAT ( ' This item is NOT allowed at this location !' )
C
      END

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
      subroutine DIVAG(TSPECS, Y, F, KORD, IFLAG, NSTOP, GNEW, GT)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2001-09-07 DIVAG  Krogh  Changes to allow user tol on G-Stops.
c>> 1995-06-20 DIVAG  Krogh  Fixed problem introduced with last change.
c>> 1995-05-09 DIVAG  Krogh  Fixed G-Stop/discontinuity code interaction
C>> 1994-11-11 DIVAG  Krogh  Declared all vars.
c>> 1994-10-20 DIVAG  Krogh  Changes to use M77CON
c>> 1994-09-12 DIVAG  Krogh  Added CHGTYP code.
c>> 1994-08-17 DIVAG  Krogh  Modified internal comment.
c>> 1994-03-07 DIVAG  Krogh  Allow larger order in single precision.
c>> 1993-04-27 DIVAG  Krogh  Additions for Conversion to C.
c>> 1992-10-12 DIVAG  Krogh  Fixed G-Stop/discontinuity code interaction
c>> 1992-09-17 DIVAG  Krogh  Slight change in check for sign change.
c>> 1992-04-08 DIVAG  Krogh  Unused labels 140,150,230, and 250 removed.
c>> 1992-03-10 DIVAG  Krogh  Fixed value for KDIM in single p. version.
c>> 1990-01-29 DIVAG  Krogh  Added arg to call to DERMN.
c>> 1988-03-04 DIVAG  Krogh  Initial code.
c
c--D replaces "?": ?IVAG,?IVABU,?IVAEV,?IVAIN,?IVAMC,?IVASC,?MESS,?ZERO
c
c     -XXXG(TSPECS, Y, F, KORD, IFLAG, NSTOP, GNEW, GT)
c
c  SUBROUTINE TO LOCATE OUTPUT POINTS AT ZEROS OF ARBITRARY
c  FUNCTIONS  **** GSTOPS **** FOR DIFFERENTIAL EQUATION
c  INTEGRATOR -ODE (OR -IVA).
c
      integer KORD(*), IFLAG, NSTOP
c--D Next line special: P=>D, X=>Q
      double precision TSPECS(*), Y(*), TOLD, TSAVE
      double precision F(*), GNEW(*), GT(*), GOLD
      save GOLD, TOLD, TSAVE
c
c++SP Default KDIM = 16
c++  Default KDIM = 20
c++  Default MAXORD = 2, MAXSTF = 1
      integer KDIM, MAXORD, MAXSTF
c++ Substitute for KDIM, MAXORD, MAXSTF below
      parameter (KDIM = 20, MAXORD = 2, MAXSTF = 1)
c--D Next line special: P=>D, X=>Q
      double precision TN
      double precision XI(KDIM)
c
c--D Next line special: P=>D, X=>Q
      double precision TG(2), TGSTOP(2), TMARK, TMARKX, TOUT, TOLG
      double precision ALPHA(KDIM), BETA(KDIM+1)
      double precision  D(MAXSTF+MAXORD,MAXORD), G(KDIM,MAXORD)
      double precision V(KDIM+MAXORD)
      double precision HC, HDEC, HINC, HINCC, HMAX, HMAXP9, HMIN
      double precision FDAT(11)
c
      double precision DS(MAXSTF+MAXORD, MAXORD), GS(KDIM)
      double precision SIGMA(KDIM), RBQ(KDIM), DNOISE
      double precision EAVE, EIMAX, EIMIN, EMAX, EREP, ROBND, SNOISE
c
c.    SPECIFICATION OF ENVIRONMENTAL CONSTANTS.
      double precision EEPS10, EEPS16, EROV10, EEPS2
      double precision EEPT75, EOVEP2, OVTM75, OVD10
      common / DIVAEV / EEPS2, EEPT75, EOVEP2, OVTM75, OVD10, EEPS10,
     1   EEPS16, EROV10
      save / DIVAEV /
      integer IOPST, KORDI, KQMAXD, KQMAXI, LDT, MAXDIF, MAXINT, NKDKO,
     1   NTE, NYNY, NDTF, NUMDT
      common / DIVASC / TN, XI, IOPST, KORDI, KQMAXD, KQMAXI, LDT,
     1   MAXDIF, MAXINT, NKDKO, NTE, NYNY, NDTF, NUMDT
c
      integer ICF,ICS,IGFLG,IGTYPE(2),IGSTOP(2),ILGREP,INGS,IOP3,IOP4,
     1   IOP5,IOP6,IOP7,IOP8,IOP9,IOP10,IOP11,IOP12,IOP13,IOP14,IOP15,
     2   IOP16,IOP17,IOP18,IOP19,IOP20,IOP21,IOP22,IOP21S,ITOLEP,IY,
     3   KEMAX,KIS,KMARK,KORD1I,KORD2I,KPRED,KQDCON,KQICON,KQMAXS,
     4   KQMXDS,KQMXIL,KQMXIP,KQMXIS,KSC,KSOUT,KSSTRT,KSTEP,LEX,LINC,
     5   LINCD,LINCQ,LSC,MAXKQD,MAXKQI,METHOD,NE,NEPTOL,NG,NGTOT,
     6   NOISEQ,NOUTKO,NTOLF,NY,IDAT(6)
      common /DIVAMC/ TG,TGSTOP,TMARK,TMARKX,TOUT,TOLG,HC,HDEC,HINC,
     1   HINCC,HMAX,HMAXP9,HMIN,ALPHA,BETA,D,G,V,DS,GS,SIGMA,RBQ,DNOISE,
     2   EAVE,EIMAX,EIMIN,EMAX,EREP,ROBND,SNOISE,FDAT,ICF,ICS,IGFLG,
     3   IGTYPE,IGSTOP,ILGREP,INGS,IOP3,IOP4,IOP5,IOP6,IOP7,IOP8,IOP9,
     4   IOP10,IOP11,IOP12,IOP13,IOP14,IOP15,IOP16,IOP17,IOP18,IOP19,
     5   IOP20,IOP21,IOP22,IOP21S,ITOLEP,IY,KEMAX,KIS,KMARK,KORD1I,
     6   KORD2I,KPRED,KQDCON,KQICON,KQMAXS,KQMXDS,KQMXIL,KQMXIP,KQMXIS,
     7   KSC,KSOUT,KSSTRT,KSTEP,LEX,LINC,LINCD,LINCQ,LSC,MAXKQD,MAXKQI,
     8   METHOD,NE,NEPTOL,NG,NGTOT,NOISEQ,NOUTKO,NTOLF,NY,IDAT
      save / DIVAMC / , / DIVASC /
c
      integer I, IG, IGFLGS, IZFLAG, KEXIT, NGSTOP(2)
      double precision HH
      equivalence (G(1,1), HH), (NGSTOP(1), IOP6), (KEXIT, IOP17),
     1   (IZFLAG, IY), (IGFLGS, ITOLEP)
c
c                      Declarations for error message processing.
c
      integer MEMDA1, MERET, MEEMES
      parameter (MEMDA1 =27)
      parameter (MERET  =51)
      parameter (MEEMES =52)
      integer MACT(7)
c ********* Error message text ***************
c[Last 2 letters of Param. name]  [Text generating message.]
cAA DIVAG$B
cAB Call with bad values of KORD.  KORD(1)=$I, KORD(2)=$I, when $C
c   TSPECS(1)=$F and KSTEP=$M.$E
      integer LTXTAA,LTXTAB
      parameter (LTXTAA= 1,LTXTAB= 8)
      character MTXTAA(1) * (95)
      data MTXTAA/'DIVAG$BCall with bad values of KORD.  KORD(1)=$I, KOR
     *D(2)=$I, when TSPECS(1)=$F and KSTEP=$M.$E'/
      data MACT / MEMDA1, 0, MEEMES, 68, 24, 0, MERET /
c
c ****************** START OF EXECUTABLE CODE **************
c
      IFLAG = 1
      IG = KORD(2)
      if ((IG .ne. 0) .and. (IG .ne. 1)) go to 500
      if (IGFLG - 3) 10, 80, 70
   10 if (IGFLG - 1) 20, 210, 60
c
c ******************** INITIAL POINT ***********************
c
   20 if (IGFLG .eq. -3) then
         IGFLG = 5
         return
      end if
      IGTYPE(IG + 1) = 0
      if ((NGSTOP(IG + 1) .le. 0) .or. (IG + IGFLG .eq. -1)) go to 30
      IGFLG = IG - 2
      go to 40
   30 IGFLG = 5
   40 NG = NGSTOP(2 - IG)
      do 50 I = 1, NG
   50    GT(I) = GNEW(I)
      go to 480
c
c     **** USER HAS BEEN TOLD THAT A GSTOP WAS FOUND
c          TEST IF CALLED FROM OUTPUT WHEN CALL SHOULD
c          BE FROM DERIVS
   60 if ((IGTYPE(1) .eq. 0) .and. (IG .ne. 0)) go to 420
c     **** PROTECT AGAINST NOISEY G NEAR THE ZERO
      if (GNEW(INGS) .eq. 0.D0) GNEW(INGS) = GT(INGS)
c
c ****** TEST FOR CHANGE IN THE SIGN OF A G ****************
c
   70 NG = NGSTOP(2 - IG)
      INGS = 0
   80 INGS = INGS + 1
      if (INGS .gt. NG) if (IGFLG - 4) 400, 380, 480
      if (GNEW(INGS)) 90, 100, 110
   90 if (GT(INGS)) 120, 120, 130
  100 if (GT(INGS)) 130, 80, 130
  110 if (GT(INGS)) 130, 120, 120
  120 GT(INGS) = GNEW(INGS)
      go to 80
c
c ********* A SIGN CHANGE HAS BEEN FOUND *******************
c
  130 NSTOP = INGS
      if (IG .eq. 0) NSTOP = -INGS
      if (IGFLG .ne. 5) go to 200
c     **** USUAL CASE -- TEST IF OUTPUT POINT PRECEDES THE
c          SIGN CHANGE, OR IF PREDICTING, CORRECTING, OR
c          NOT THROUGH THE FIRST STEP.
c     **** TEST IF AN INTERPOLATED G WAS WHAT CHANGED SIGN
      if (IG .ne. 0) go to 180
c     **** BACK UP DIFFERENCES AND OTHER STUFF TO BEGINNING
c          OF THE STEP
      call DIVABU(F, KORD)
c     **** TEST IF CORRECTING
      if (KORD1I .eq. 2) go to 170
c     **** TEST IF THROUGH THE FIRST STEP
      if (LSC .lt. 4) go to 180
c     **** IF FIRST DERIVATIVE EVALUATION OF THE FIRST
c          STEP, FIND THE GSTOP, AND USE IT TO GET A NEW
c          INITIAL STEPSIZE
      if (LSC .eq. 7) go to 200
c     **** SET NEW STEPSIZE AFTER SIGN CHANGE WHEN STARTING
  160 HH = TSPECS(1) - TN
c     **** SET KEXIT TO TRY NEW STEPSIZE
  170 KEXIT = 1
      TSPECS(1) = TN
      go to 460
c     **** SET KEXIT FOR USUAL CASE
  180 KEXIT = IG + 2
c     **** TEST IF SIGN CHANGE IN G PRECEDES NEXT OUTPUT PT.
      if (HH * (TSPECS(1) - TMARK)) 200, 200, 190
c     **** SET UP TO EVALUATE G AT OUTPUT POINT
  190 IGFLG = 4
      TSPECS(1) = TMARK
      NSTOP = 0
      go to 240
c
c ***************** FIND THE ZERO OF G *********************
c
c     **** INITIALIZE ZERO FINDER
  200 TOLD = TG(2 - IG)
      GOLD = GT(INGS)
      TSAVE = TSPECS(1)
      IGFLGS = IGFLG
      IGFLG = 1
      IZFLAG = 0
      go to 220
c     **** TEST IF ZERO ALREADY FOUND
  210 if (IZFLAG - 1) 350, 220, 310
  220 continue
      call DZERO(TSPECS(1), GNEW(INGS), TOLD, GOLD, IZFLAG, TOLG)
c     **** TEST FOR CONVERGENCE
      if (IZFLAG .ne. 1) go to 260
c     **** INTERPOLATE NEW Y, AND GO COMPUTE G AGAIN
  240 call DIVAIN(TSPECS(1), Y, F, KORD)
      IFLAG = 4
      KORD2I = IG - 3
      return
c     **** CONVERGENCE -- CHOOSE TOLD TO GIVE A CHANGE
c          IN SIGN
  260 if (GNEW(INGS) .eq. 0.D0) go to 290
      if (TSPECS(1) - TOLD) 270, 300, 280
  270 if (HH) 290, 300, 300
  280 if (HH) 300, 300, 290
  290 TOLD = TSPECS(1)
c     **** CHECK IF SIGN CHANGE DUE TO NOISE
  300 TSPECS(1) = TOLD + XI(1)
      go to 240
  310 TSPECS(1) = TOLD
      if (GNEW(INGS)) 320, 340, 330
  320 if (GT(INGS)) 340, 360, 360
  330 if (GT(INGS)) 360, 360, 340
c     **** ZERO WAS EVIDENTLY DUE TO NOISE
  340 TSPECS(1) = TSAVE
      IZFLAG = 0
      go to 370
  350 IGFLG = IGFLGS
c     SET KORD2I TO INITIAL VALUE TO AVOID LOOP
      KORD2I = IG
      go to 80
c     **** SAVE INFORMATION ABOUT THE STOP
  360 IGFLG = 3
      TGSTOP(2 - IG) = TSPECS(1)
      IGTYPE(2 - IG) = IZFLAG + 3
      IGSTOP(2 - IG) = NSTOP
  370 NSTOP = 0
      go to 240
c
c ************** AFTER SEARCH FOR A SIGN CHANGE ************
c
c     **** NO SIGN CHANGE AT A T OUTPUT POINT
c     TEST IF CALLED FROM OUTPUT
  380 if (IG .ne. 0) go to 390
c     SET UP FOR CALL TO OUTPUT
      KORD1I = 7
      KORD2I = -2
      IFLAG = 3
      go to 480
c     **** ADJUST KEXIT AND SET UP TO GIVE OUTPUT
  390 KEXIT = KEXIT + 2
      KORD1I = min(KMARK, 5)
      KORD(3) = KMARK
      KORD(1) = KORD1I
      IGFLG = 5
      IFLAG = 2
      go to 470
c     **** TEST IF USER HAS BEEN TOLD OF GSTOP
  400 if (IGFLG .eq. 2) go to 450
c     **** A GSTOP HAS BEEN FOUND
c     TEST IF STARTING
      if (LSC .eq. 7) go to 160
      IFLAG = IGTYPE(2 - IG)
      NSTOP = IGSTOP(2 - IG)
      INGS = abs(NSTOP)
      if (INGS .eq. 0) go to 410
      GT(INGS) = -GT(INGS)
      if (IG .eq. 0) go to 430
      IGFLG = 2
c     If interpolated GSTOP was found set to check again in case of
c     multiple stops at exactly the same point.
      if (IGTYPE(1) .ne. 0) go to 440
c     **** TELL USER OF AN EXTRAPOLATED GSTOP
  410 IFLAG = IGTYPE(2)
      NSTOP = IGSTOP(2)
      INGS = abs(NSTOP)
c     **** SET SO DERIVS IS CALLED WITH KORD(1) = KPRED
  420 KORD1I = KPRED
      KORD2I = -3
      return
c     **** AN EXTRAPOLATED GSTOP WAS FOUND, SET UP TO CHECK
c          INTERPOLATED STOPS (IF ANY)
  430 NG = NGSTOP(1)
      INGS = 0
      IFLAG = 3
      NSTOP = IGSTOP(2)
c     **** SET SO OUTPUT IS CALLED WITH KORD(1) = 7
  440 KORD1I = 7
      KORD2I = -2
      go to 490
c     **** CHECK THAT AN EXTRAPOLATED G-STOP IS NOT MISSED
  450 if ((IG .eq. 0) .or. (IGTYPE(2) .eq. 0)) go to 460
c     SET TO CHECK FOR INTERPOLATED G-S.
      TG(1) = TSPECS(1)
      IGTYPE(1) = 0
      TSPECS(1) = TGSTOP(2)
      INGS = 0
      IGFLG = 3
      go to 240
c     **** SET SO INTEGRATOR GOES TO PLACE DIRECTED BY KEXIT
  460 NSTOP = 0
      IGFLG = 5
      IFLAG = 3
  470 KORD2I = -7
c     **** STORE INFO. ON LAST G COMPUTED
  480 IGTYPE(2 - IG) = 0
  490 TG(2 - IG) = TSPECS(1)
      return
c
c ********************** ERROR PROCESSING ******************
c
  500 MACT(2) = KSTEP
c--D Next line special: P=>S, X=>D
      call DMESS(MACT, MTXTAA, KORD, TSPECS)
      IFLAG = 8
      KEXIT = 6
      go to 470
      end


text:
      SUBROUTINE CMCOMB (NPS,NENT,NDOF,IC)
C
C     THIS SUBROUTINE COMBINES CONNECTION ENTRIES THAT HAVE BEEN SPECIFI
C     ON SEVERAL CONCT OR CONCT1 CARDS.
C
      EXTERNAL        ORF
      LOGICAL         MATCH
      INTEGER         CE(9),CEID,SCCONN,SCMCON,BUF1,BUF2,SAVCE,ORF,Z,
     1                SCR2,BUF3,SCORE,COMSET,IO(10),SACONN,AAA(2)
      DIMENSION       IC(NENT,NPS,NDOF),LIST(32),KROW(6),IERTAB(2000)
      COMMON /CMB001/ SCR1,SCR2,JUNK(2),SCCONN,SCMCON
      COMMON /CMB002/ BUF1,BUF2,BUF3,JUNK1(2),SCORE,LCORE
      COMMON /ZZZZZZ/ Z(1)
      COMMON /BLANK / ISTEP,IDRY
      DATA    AAA   / 4HCMCO,4HMB   /
C
C     CE IS THE CONNECTION ENTRY
C     KROW(I) IS THE NO. OF ROWS IN THE ITH DOF MATRIX
C
      IERSUB = 0
      ITOMNY = 0
      IFILE  = SCCONN
      CALL OPEN (*400,SCCONN,Z(BUF1),0)
      IFILE = SCMCON
      CALL OPEN (*400,SCMCON,Z(BUF2),0)
      NREC  = -1
      NPSS  = NPS - 1
      NWORD = NPS + 1
      IENT  = 0
      DO 10 I = 1,6
   10 KROW(I) = 0
      SAVCE = 0
   20 CALL READ (*410,*190,SCMCON,CEID,1,0,NNN)
      NREC  = CEID - SAVCE - 1
      SAVCE = CEID
C
C     GO FIND ENTRY NO. CEID
C
      IFILE = SCCONN
      IF (NREC .EQ. 0) GO TO 40
      DO 30 I = 1,NREC
      CALL FWDREC (*420,SCCONN)
   30 CONTINUE
C
C     READ IN CONNECTION ENTRY
C
   40 CALL READ (*410,*50,SCCONN,CE,10,1,NNN)
C
C     FIND WHICH DOF ARE PRESENT IN CONNECTION ENTRY
C
   50 CALL DECODE (CE(1),LIST,NCOMP)
      DO 180 I = 1,NCOMP
      ICOMP = LIST(I) + 1
      IF (KROW(ICOMP) .EQ. 0) GO TO 170
C
C     FIND FIRST NON-ZERO ENTRY IN CURRENT CE
C
      DO 60 J = 1,NPSS
      IF (CE(J+2) .EQ. 0) GO TO 60
      ISUB = J
      GO TO 70
   60 CONTINUE
C
C     NOW HAVE FOUND FIRST NON-ZERO, SEARCH FOR POSSIBLE
C     MATCHING ENTRIES IN MATRIX
C
   70 NLOOP = KROW(ICOMP)
      DO 140 J = 1,NLOOP
      MATCH  = .FALSE.
      NERSUB = 0
      DO 110 JJ = ISUB,NPSS
      IF (IC(J,JJ,ICOMP).EQ.0 .OR. CE(JJ+2).EQ.0) GO TO 110
      IF (IC(J,JJ,ICOMP)-CE(JJ+2)) 80,100,80
   80 IF (IERSUB+NERSUB .GT. 2000) ITOMNY = 1
      IF (IERSUB+NERSUB .GT. 2000) GO TO 90
      IERTAB(IERSUB+NERSUB+1) = ICOMP
      IERTAB(IERSUB+NERSUB+2) = JJ
      IERTAB(IERSUB+NERSUB+3) = IC(J,JJ,ICOMP)
      IERTAB(IERSUB+NERSUB+4) = CE(JJ+2)
      NERSUB = NERSUB + 4
   90 CONTINUE
      GO TO 110
  100 MATCH = .TRUE.
  110 CONTINUE
      IF (MATCH) IERSUB = IERSUB + NERSUB
      IF (.NOT.MATCH) GO TO 140
      DO 130 JJ = ISUB,NPSS
      IF (CE(JJ+2).NE.0 .AND. IC(J,JJ,ICOMP).NE.0) GO TO 130
      IC(J,JJ,ICOMP) = IC(J,JJ,ICOMP) + CE(JJ+2)
  130 CONTINUE
      IC(J,NPSS+1,ICOMP) = ORF(IC(J,NPSS+1,ICOMP),CE(2))
      GO TO 180
  140 CONTINUE
  150 DO 160 JJ = 1,NPSS
      IC(NLOOP+1,JJ,ICOMP) = CE(JJ+2)
  160 CONTINUE
      IC(NLOOP+1,NPSS+1,ICOMP) = CE(2)
      KROW(ICOMP) = KROW(ICOMP) + 1
      GO TO 180
  170 NLOOP = 0
      GO TO 150
  180 CONTINUE
      GO TO 20
  190 CONTINUE
      IF (IERSUB .EQ. 0) GO TO 200
C
C     GENERATE ERROR TABLE AND TERMINATE
C
      CALL CLOSE (SCCONN,1)
      CALL CLOSE (SCMCON,1)
      CALL CMTRCE (IERTAB,IERSUB,ITOMNY)
      IDRY = -2
      RETURN
C
  200 CONTINUE
      CALL CLOSE (SCCONN,1)
      IFILE = SCR2
      CALL OPEN (*400,SCR2,Z(BUF3),1)
      DO 240 K = 1,NDOF
      IROW = KROW(K)
      IF (IROW) 240,240,210
  210 DO 230 I = 1,IROW
      IO(1) = K
      IO(2) = IC(I,NPS,K)
      DO 220 J = 1,NPSS
      IO(J+2) = IC(I,J,K)
  220 CONTINUE
      CALL WRITE (SCR2,IO(1),NPS+1,0)
  230 CONTINUE
  240 CONTINUE
      CALL WRITE (SCR2,IO(1),0,1)
      CALL CLOSE (SCR2,1)
      CALL OPEN (*400,SCR2,Z(BUF3),0)
      CALL READ (*410,*250,SCR2,Z(SCORE),LCORE,1,NWD)
      GO TO 430
  250 CALL SORT (0,0,NPS+1,2,Z(SCORE),NWD)
      CALL CLOSE (SCR2,1)
      CALL OPEN (*400,SCR2,Z(BUF3),1)
      IFIN = SCORE + NWD - 1
      IINC = NPS + 1
      DO 310 I = SCORE,IFIN,IINC
      IF (Z(I)) 260,310,260
  260 COMSET = Z(I)
      IBEG = I + IINC
      DO 280 J = IBEG,IFIN,IINC
      IF (Z(J) .EQ. 0) GO TO 280
      IF (Z(J+1) .GT. Z(I+1)) GO TO 290
      DO 270 K = 1,NPSS
      IF (Z(I+K+1) .NE. Z(J+K+1)) GO TO 280
  270 CONTINUE
      COMSET = 10*COMSET+Z(J)
      Z(J) = 0
  280 CONTINUE
  290 CALL ENCODE (COMSET)
      IO(1) = COMSET
      DO 300 KK = 1,NPS
      IO(1+KK) = Z(I+KK)
  300 CONTINUE
      CALL WRITE (SCR2,IO,NPS+1,1)
  310 CONTINUE
      CALL REWIND (SCMCON)
      IFILE = SCMCON
      CALL READ (*410,*320,SCMCON,Z(SCORE),LCORE,1,NMCON)
  320 NCE = 0
      SACONN = SCCONN
      CALL OPEN (*400,SCCONN,Z(BUF1),0)
  330 CALL READ (*360,*340,SCCONN,CE,10,1,NNN)
  340 NCE = NCE + 1
      DO 350 I = 1,NMCON
      IF (NCE .EQ. Z(SCORE+I-1)) GO TO 330
  350 CONTINUE
      CALL WRITE (SCR2,CE,NPS+1,1)
      GO TO 330
  360 CALL CLOSE (SCMCON,1)
      CALL CLOSE (SCCONN,1)
      CALL CLOSE (SCR2,1)
      SCCONN = SCR2
      SCR2   = SACONN
      RETURN
C
  400 IMSG = -1
      GO TO 440
  410 IMSG = -2
      GO TO 440
  420 IMSG = -3
      GO TO 440
  430 IMSG = -8
  440 CALL MESAGE (IMSG,IFILE,AAA)
      RETURN
      END


submodule(euler_interface_m) euler_prob_0031_m
    implicit none

contains

    module character(len=20) function euler0031()
        write (euler0031, "(i20)") ans(200)
    end function euler0031

    integer function ans(n)
        integer, intent(in) :: n
        integer :: coins(0:7), i, j
        integer :: ans_arr(0:7, 0:n)

        coins = [1, 2, 5, 10, 20, 50, 100, 200]
        ans_arr(1:7, :) = 0
        ans_arr(0, :) = 1

        outer: do j = 0, n
            inner: do i = 1, 7
                associate (next => ans_arr(i, j), prev => ans_arr(i - 1, j))
                    if (j < coins(i)) then
                        next = prev
                    else
                        next = prev + ans_arr(i, j - coins(i))
                    end if
                end associate
            end do inner
        end do outer
        ans = ans_arr(7, n)
    end function ans

end submodule euler_prob_0031_m


text:
MODULE globvars

!*************************************************************************************************!
!*
!*        Global Variables Module
!*
!*  Contains declaration of all global variables and subroutines for:
!*
!*      1) Initialisation of global variables
!*
!*************************************************************************************************!

  type basisfn                              ! an array of size nbf of this type holds the basis set
    complex(kind=8), dimension(:), allocatable::z        ! Coherent state sub-array - 1 value per dof
    complex(kind=8)                            ::D_big    ! Prefactor - 1 value per basis function
    complex(kind=8), dimension(:), allocatable::d_pes    ! Electronic State pre-exponential - 1 value per state
    real   (kind=8), dimension(:), allocatable::s_pes    ! Classical action - 1 value per electronic state
    complex(kind=8), dimension(:), allocatable::a_pes    ! Electronic state amplitude - 1 value per state and =de^(iS)
  end type basisfn

  type hamiltonian                  ! a matrix of size nbf x nbf of this type hold the hamiltonian
    complex(kind=8), dimension(:,:), allocatable::Hjk      ! matrix of size npes x npes
  end type hamiltonian

  integer:: in_nbf     ! number of basis functions
  integer:: ndim       ! number of dimensions/degrees of freedom
  integer:: npes       ! determines n.o configurations
  integer:: in_pes     ! potential energy surface 1 or 2
  integer:: Ntries     ! Number of recalculations allowed before an error occurs
  integer:: errorflag  ! The global fatal error flag. Stops operation
  integer:: conjflg    ! Flag to determine whether Conjugate repetition will occur
  integer:: restrtflg  ! Flag for restarting a previous run for when time has run out
  integer:: reptot     ! Total number of repeats to be carried out in program
  integer:: trainsp    ! number of time steps between adjacent basis functions in a train
  integer:: train_len  ! default number of basis functions in a train for swarms of trains
  integer:: swtrn_swrm ! size of the centre swarm in the swarm of trains
  integer:: clonemax   ! maximum number of cloning events allowed per basis function
  integer:: clonefreq  ! minimum number of timesteps between concurrent coloning events
  integer:: qss        ! quantum superposition sampling change to initial amplitudes
  integer:: adptreptot ! Adapted number of repetitions for MCEv1 cloning

  real(kind=8),external :: ZBQLNOR ! The normally distributed random number external function

  real(kind=8) :: wmax_sb          ! Maximum frequency **SPIN BOSON ONLY**
  real(kind=8) :: beta_sb          ! Temperature parameter **SPIN BOSON ONLY**
  real(kind=8) :: delta_sb         ! Coupling between PESs in Hamiltonian - provides off diagonals **SPIN BOSON ONLY**
  real(kind=8) :: eps_sb           ! Symmetry parameter used in calculation of diagonals in hamiltonian **SPIN BOSON ONLY**
  integer :: freqflg_sb            ! Flag for reading pre-calculated frequencies (1=read, 0=calculate) **SPIN BOSON ONLY**

  real(kind=8) :: wc_exp           ! Cutoff frequency **SPIN BOSON ONLY**
  real(kind=8) :: kondo_exp        ! Kondo parameter **SPIN BOSON ONLY**
  real(kind=8) :: wmax_exp         ! Maximum frequency factor **SPIN BOSON ONLY**

  real(kind=8) :: wc_dl            ! Cutoff frequency **DRUDE LORENTZ ONLY**
  real(kind=8) :: lambda_dl        ! Reorganisation Energy parameter **DRUDE LORENTZ ONLY**
  real(kind=8) :: wmax_dl          ! Maximum frequency factor **DRUDE LORENTZ ONLY**

  real(kind=8) :: freq_hp          ! Frequency of a Harmonic Potential **HARMONIC POTENTIAL ONLY**

  real(kind=8) :: dissen_mp        ! Dissasociation Energy **MORSE POTENTIAL ONLY**
  real(kind=8) :: freq_mp          ! frequency of morse potential **MORSE POTENTIAL ONLY**
  real(kind=8) :: mass_mp          ! mass of particle in morse potential **MORSE POTENTIAL ONLY**
  real(kind=8) :: a0_mp            ! Well shape parameter for morse oscillator **MORSE POTENTIAL ONLY**

  real(kind=8) :: sigp             ! Width of the distribution of imaginary parts of the initial wavefunction
  real(kind=8) :: sigq             ! Width of the distribution of real parts of the initial wavefunction
  real(kind=8) :: gam              ! Gamma value, used to calculate the widths sigp and sigq
  real(kind=8) :: initalcmprss     ! Initial compression parameter. Can be automatically tweaked or left static.
  real(kind=8) :: mu               ! Center value for the real and imaginary parts of the initial wavefunction
  real(kind=8) :: hbar             ! hbar. Currently redundant as hbar assumed to be 1
  real(kind=8) :: Ebfmin           ! Minimum energy allowed for a single basis function
  real(kind=8) :: Ebfmax           ! Maximum energy allowed for a single basis function
  real(kind=8) :: dtmin            ! Minimum stepsize for adaptive step system
  real(kind=8) :: dtmax            ! Maximum stepsize for adaptive step system
  real(kind=8) :: timeend          ! Final time value for simulation
  real(kind=8) :: timestrt         ! Initial time value for simulation (instability occurs when =/= 0)
  real(kind=8) :: dtinit           ! Initial/Only time step size for adaptive/static stepsize
  real(kind=8) :: initsp           ! Grid spacing for regular grids
  real(kind=8) :: bfeps            ! Adaptive basis set cutoff parameter
  real(kind=8) :: uplimnorm        ! upper limit of the norm
  real(kind=8) :: lowlimnorm       ! lower limit of the norm
  real(kind=8) :: sqrtpi           ! square root of pi
  real(kind=8) :: thresh           ! cloning threshold
  real(kind=8) :: qsce             ! QSC exclusion paramter
  real(kind=8) :: pirl             ! pi

  character(LEN=5) :: ECheck       ! Flag to determine if the energy of basis functions should be checked
  character(LEN=5) :: basis        ! Initial basis set structure option
  character(LEN=6) :: cloneflg     ! Flag for cloning
  character(LEN=5) :: method       ! MCEv1, MCEv2 or CCS used. Later versions to have other methods available
  character(LEN=4) :: randfunc     ! Random number generation function identifier (zbql/gaus)
  character(LEN=3) :: specden      ! the spectral density type (EXP,DL or UBO ---- LHC to come)
  character(LEN=2) :: sys          ! System to be simulated.
  character(LEN=1) :: gen          ! Flag to determine if basis set generation needed (global variant)
  character(LEN=1) :: prop         ! Flag to determine if basis set propagation needed
  character(LEN=1) :: step         ! Flag to determine whether adaptive or static stepsize propagation needed
  character(LEN=1) :: cmprss       ! Flag to determine if automatic tweaking of the compression parameter needed

  complex(kind=8) :: i             ! The imaginary unit

contains

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

  subroutine initialise  !  Level 1 Subroutine

    implicit none

    ! This subroutine initialises all global variables to zero and sets the imaginary unit variable.

    in_nbf = 0
    ndim = 0
    npes = 0
    in_pes = 0
    Ntries = 0
    errorflag = 0
    conjflg = 0
    reptot = 0
    trainsp = 0
    train_len = 0
    swtrn_swrm = 0
    adptreptot = 0

    wmax_sb = 0.0d0          ! SPIN BOSON PARAMETER
    eps_sb = 0.0d0           ! SPIN BOSON PARAMETER
    delta_sb = 0.0d0         ! SPIN BOSON PARAMETER
    beta_sb = 0.0d0          ! SPIN BOSON PARAMETER
    freqflg_sb = 0           ! SPIN BOSON PARAMETER

    wc_exp = 0.0d0           ! SPIN BOSON [EXPONENTIAL CUTOFF] ONLY
    kondo_exp = 0.0d0        ! SPIN BOSON [EXPONENTIAL CUTOFF] ONLY
    wmax_exp = 0.0d0         ! SPIN BOSON [EXPONENTIAL CUTOFF] ONLY

    wc_dl = 0.0d0            ! SPIN BOSON [DRUDE LORENTZ CUTOFF] ONLY
    lambda_dl = 0.0d0        ! SPIN BOSON [DRUDE LORENTZ CUTOFF] ONLY
    wmax_dl = 0.0d0          ! SPIN BOSON [DRUDE LORENTZ CUTOFF] ONLY

    freq_hp = 0.0d0          ! HARMONIC OSCILLATOR PARAMETER

    freq_mp = 0.0d0          ! MORSE POTENTIAL PARAMETER
    mass_mp = 0.0d0          ! MORSE POTENTIAL PARAMETER
    dissen_mp = 0.0d0        ! MORSE POTENTIAL PARAMETER
    a0_mp = 0.0d0            ! MORSE POTENTIAL PARAMETER

    sigp = 0.0d0
    sigq = 0.0d0
    gam = 0.0d0
    initalcmprss = 0.0d0
    mu = 0.0d0
    Ebfmin = 0.0d0
    Ebfmax = 0.0d0
    hbar = 1.0d0
    dtmin = 0.0d0
    dtmax = 0.0d0
    timeend = 0.0d0
    timestrt = 0.0d0
    dtinit = 0.0d0
    initsp = 0.0d0
    bfeps = 0.0d0
    sqrtpi = 1.7724538509055160272981674833411451827975494561223871d0
    thresh = 0.249d0
    pirl = sqrtpi**2.0d0

    i = (0.0d0,1.0d0)

  end subroutine initialise

END MODULE globvars

max_stars_repo_name: C-Symonds/MCE

max_issues_repo_name: C-Symonds/MCE

max_forks_repo_name: C-Symonds/MCE


text:
Describe Users/ShaolinHero88 here.

20080923 12:32:41 nbsp Welcome to the Wiki. Are you a member of Alpha Zeta Psi? Could you add more information to that page?  Users/ElleWeber


text:
      SUBROUTINE GEO_LABEL
     &          (lat,lon,lat_lbl,lon_lbl,nrdec)

c***********************************************************************
c                   subroutine geo_label
c***********************************************************************

c  Program Source:  Naval Ocean Systems Center - Code 542

c  Date:
c     01 Mar 1995

c  Function:
c     This program writes strings for coordinate labels for the
c     geographic displays.

c     Latitudes and longitudes in degrees
c     Sign convention is + for N/E and - for S/W

c  Parameters passed:
c     lat           [r] latitude
c     lon           [r] longitude
c     lat_lbl       [c] label for latitude
c     lon_lbl       [c] label for longitude
c     nrdec         [i] number of decimal places output
c                       Only the integer part if <0

c  Parameters returned:

c  Common blocks referenced:

c  Functions and subroutines referenced:
c     abs
c     int
c     mod

c  References:

c  Change History:

c*******************!***************************************************

      IMPLICIT NONE

      character*(*) lat_lbl
      character*(*) lon_lbl
      integer       nrdec
      real          lat
      real          lon

      character* 12 frmt

      if (nrdec .lt. 0) then

         write(frmt,'(''(i2,a)'')')
         if (lat .ge. 0.) then

            write(lat_lbl,frmt) INT(ABS(lat)),'N'
         else

            write(lat_lbl,frmt) INT(ABS(lat)),'S'
         end if

         write(frmt,'(''(i3,a)'')')
         if (lon .gt. 0. .and. MOD(lon,360.) .lt. 180.) then

            write(lon_lbl,frmt) INT(MOD(lon,360.)),'W'
         else
     &   if (lon .lt. 0. .and. MOD(lon,360.) .lt. -180.) then

            write(lon_lbl,frmt) INT(360.+MOD(lon,360.)),'W'
         else
     &   if (lon .le. 0. .and. MOD(lon,360.) .ge. -180.) then

            write(lon_lbl,frmt) INT(ABS(MOD(lon,360.))),'E'
         else

            write(lon_lbl,frmt) INT(360.-ABS(MOD(lon,360.))),'E'
         end if
      else

         if (nrdec .lt. 7) then

            write(frmt,'(''(f'',i1,''.'',i1'',a)'')') 3+nrdec,nrdec
         else

            write(frmt,'(''(f'',i2,''.'',i1'',a)'')') 3+nrdec,nrdec
         end if

         if (lat .ge. 0.) then

            write(lat_lbl,frmt) ABS(lat),'N'
         else

            write(lat_lbl,frmt) ABS(lat),'S'
         end if
         if (nrdec .lt. 6) then

            write(frmt,'(''(f'',i1,''.'',i1'',a)'')') 4+nrdec,nrdec
         else

            write(frmt,'(''(f'',i2,''.'',i1'',a)'')') 4+nrdec,nrdec
         end if
         if (lon .gt. 0. .and. MOD(lon,360.) .lt. 180.) then

            write(lon_lbl,frmt) MOD(lon,360.),'W'
         else
     &   if (lon .lt. 0. .and. MOD(lon,360.) .lt. -180.) then

            write(lon_lbl,frmt) 360.+MOD(lon,360.),'W'
         else
     &   if (lon .le. 0. .and. MOD(lon,360.) .ge. -180.) then

            write(lon_lbl,frmt) ABS(MOD(lon,360.)),'E'
         else

            write(lon_lbl,frmt) 360.-ABS(MOD(lon,360.)),'E'
         end if
      end if

      RETURN
      END      ! GEO_LABEL

ext: for

max_stars_repo_name: spinorkit/LWPC

max_issues_repo_name: spinorkit/LWPC

max_forks_repo_name: spinorkit/LWPC


text:
C$Procedure  CHBIGR ( Chebyshev expansion integral )

      SUBROUTINE CHBIGR ( DEGP, CP, X2S, X, P, ITGRLP )

C$ Abstract
C
C     Evaluate an indefinite integral of a Chebyshev expansion at a
C     specified point X. The constant of integration is selected to
C     make the integral zero when X equals the abscissa value X2S(1).
C     Return the value of the input expansion at X as well.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CHEBYSHEV
C     EPHEMERIS
C     INTEGRAL
C     MATH
C
C$ Declarations

      IMPLICIT NONE

      INTEGER               DEGP
      DOUBLE PRECISION      CP     ( * )
      DOUBLE PRECISION      X2S    ( 2 )
      DOUBLE PRECISION      X
      DOUBLE PRECISION      P
      DOUBLE PRECISION      ITGRLP

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     DEGP       I   Degree of input Chebyshev expansion.
C     CP         I   Chebyshev coefficients of input expansion.
C     X2S        I   Transformation parameters.
C     X          I   Abscissa value of evaluation.
C     P          O   Input expansion evaluated at X.
C     ITGRLP     O   Integral evaluated at X.
C
C$ Detailed_Input
C
C     DEGP       is the degree of the input Chebyshev expansion.
C
C     CP         is an array containing the coefficients of the input
C                Chebyshev expansion. The coefficient of the Ith
C                Chebyshev polynomial is contained in element CP(I+1),
C                for I = 1 : DEGP+1.
C
C     X2S        is an array containing the "transformation parameters"
C                of the domain of the expansion. Element X2S(1)
C                contains the midpoint of the interval on which the
C                input expansion is defined; X2S(2) is one-half of the
C                length of this interval; this value is called the
C                interval's "radius."
C
C                The input expansion defines a function f(X) on the
C                interval
C
C                   [ X2S(1)-X2S(2),  X2S(1)+X2S(2) ]
C
C                as follows:
C
C                   Define S = ( X - X2S(1) ) / X2S(2)
C
C
C                                  DEGP+1
C                                  __
C                                  \
C                   f(X) = g(S)  = /  CP(k)  T   (S)
C                                  --         k-1
C                                  k=1
C
C
C     X          is the abscissa value at which the function defined by
C                the input expansion and its integral are to be
C                evaluated. Normally X should lie in the closed
C                interval
C
C                   [ X2S(1)-X2S(2),  X2S(1)+X2S(2) ]
C
C                See the Restrictions section below.
C
C$ Detailed_Output
C
C     P,
C     ITGRLP     Define S and f(X) as above in the description of the
C                input argument X2S. Then P is f(X), and ITGRLP is
C                an indefinite integral of f(X), evaluated at X.
C
C                The indefinite integral satisfies
C
C                   d(ITGRLP)/dX     = f(X)
C
C                and
C
C                   ITGRLP( X2S(1) ) = 0
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the input degree is negative, the error
C         SPICE(INVALDDEGREE) is signaled.
C
C     2)  If the input interval radius is non-positive, the error
C         SPICE(INVALIDRADIUS) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Let
C
C        T ,  n = 0, ...
C         n
C
C     represent the nth Chebyshev polynomial of the first kind:
C
C        T (x) = cos( n*arccos(x) )
C         n
C
C     The input coefficients represent the Chebyshev expansion
C
C                       DEGP+1
C                       __
C                       \
C        f(X) = g(S)  = /  CP(k)  T   (S)
C                       --         k-1
C                       k=1
C
C     where
C
C        S = ( X - X2S(1) ) / X2S(2)
C
C     This routine evaluates and returns the value at X of an
C     indefinite integral F(X), where
C
C        dF(X)/dX    = f(X)  for all X in
C                            [X2S(1)-X2S(2), X2S(1)+X2S(2)]
C
C        F( X2S(1) ) = 0
C
C     The value at X of the input expansion
C
C        f(X)
C
C     is returned as well.
C
C     Note that numerical problems may result from applying this
C     routine to abscissa values outside of the interval defined
C     by the input parameters X2S(*). See the Restrictions section.
C
C     To evaluate Chebyshev expansions and their derivatives, use the
C     SPICELIB routines CHBINT or CHBDER.
C
C     This routine supports the SPICELIB SPK type 20 and PCK type 20
C     evaluators SPKE20 and PCKE20.
C
C$ Examples
C
C     The numerical results shown for this example may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     1)  Let the domain of a polynomial to be evaluated be the
C         closed interval
C
C            [20, 30]
C
C         Let the input expansion represent the polynomial
C
C                             6
C            f(X)  = g(S) = 5S
C
C         where
C
C            S     = (X - 20)/10
C
C         Let F(X) be an indefinite integral of f(X) such that
C
C            F(20) = 0
C
C         Evaluate
C
C            f(30) and F(30)
C
C
C        Example code begins here.
C
C              PROGRAM EX1
C              IMPLICIT NONE
C        C
C        C     Local variables
C        C
C              DOUBLE PRECISION      CP    ( 6 )
C              DOUBLE PRECISION      X
C              DOUBLE PRECISION      X2S   ( 2 )
C              DOUBLE PRECISION      P
C              DOUBLE PRECISION      ITGRLP
C
C              INTEGER               DEGP
C
C        C
C        C     Let our domain be the interval [10, 30].
C        C
C              X2S(1) = 20.D0
C              X2S(2) = 10.D0
C        C
C        C     Assign the expansion coefficients.
C        C
C              DEGP  = 5
C
C              CP(1) = 0.D0
C              CP(2) = 3.75D0
C              CP(3) = 0D0
C              CP(4) = 1.875D0
C              CP(5) = 0.D0
C              CP(6) = 0.375D0
C
C        C
C        C     Evaluate the function and its integral at X = 30.
C        C
C              X = 30.D0
C
C              CALL CHBIGR ( DEGP, CP, X2S, X, P, ITGRLP )
C
C        C
C        C     We make the change of variables
C        C
C        C        S(X) = (1/10) * ( X - 20 )
C        C
C        C     The expansion represents the polynomial
C        C
C        C                         5
C        C        f(X) = g(S) = 6*S
C        C
C        C     An indefinite integral of the expansion is
C        C
C        C                                    6
C        C        F(X) = G(S) * dX/dS = 10 * S
C        C
C        C     where G is defined on the interval [-1, 1]. The result
C        C     should be (due to the change of variables)
C        C
C        C          (G(1)  - G(0) ) * dX/dS
C        C
C        C        = (F(30) - F(20)) * 10
C        C
C        C        = 10
C        C
C        C     The value of the expansion at X should be
C        C
C        C        f(20) = g(1) = 6
C        C
C              WRITE (*,*) 'ITGRLP = ', ITGRLP
C              WRITE (*,*) 'P      = ', P
C
C              END
C
C
C     When this program was executed on a PC/Linux/gfortran platform,
C     the output was:
C
C        ITGRLP =   10.0000000000000000
C        P      =    6.0000000000000000
C
C
C$ Restrictions
C
C     1)  The value (X-X2S(1)) / X2S(2) normally should lie within the
C         interval -1:1 inclusive, that is, the closed interval
C         [-1, 1]. Chebyshev polynomials increase rapidly in magnitude
C         as a function of distance of abscissa values from this
C         interval.
C
C         In typical SPICE applications, where the input expansion
C         represents position, velocity, or orientation, abscissa
C         values that map to points outside of [-1, 1] due to round-off
C         error will not cause numeric exceptions.
C
C     2)  No checks for floating point overflow are performed.
C
C     3)  Significant accumulated round-off error can occur for input
C         expansions of excessively high degree. This routine imposes
C         no limits on the degree of the input expansion; users must
C         verify that the requested computation provides appropriate
C         accuracy.
C
C$ Literature_References
C
C     1)  "Numerical Recipes -- The Art of Scientific Computing" by
C         William H. Press, Brian P. Flannery, Saul A. Teukolsky,
C         Willam T. Vetterling. (See Clenshaw's Recurrence Formula.)
C
C     2)  Chebyshev polynomials. (2013, September 28). In Wikipedia,
C         The Free Encyclopedia. Retrieved 01:23, November 23, 2013,
C         from http://en.wikipedia.org/w/index.php?title=
C         Chebyshev_polynomials&oldid=574881046
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 03-DEC-2013 (NJB)
C
C-&

C$ Index_Entries
C
C     integral of chebyshev_polynomial_expansion
C     integrate chebyshev_polynomial_expansion
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
C
C     Local variables
C
      DOUBLE PRECISION      A2
      DOUBLE PRECISION      ADEGP1
      DOUBLE PRECISION      ADEGP2
      DOUBLE PRECISION      AI
      DOUBLE PRECISION      C0
      DOUBLE PRECISION      F      ( 3 )
      DOUBLE PRECISION      S
      DOUBLE PRECISION      S2
      DOUBLE PRECISION      W      ( 3 )
      DOUBLE PRECISION      Z      ( 3 )

      INTEGER               I
      INTEGER               NTERMS

C
C     Test RETURN but don't check in. Use discovery check-in.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     Check the expansion degree.
C
      IF ( DEGP .LT. 0 )  THEN

         CALL CHKIN  ( 'CHBIGR'                                )
         CALL SETMSG ( 'Expansion degree must be non-negative '
     .   //            'but was #.'                            )
         CALL ERRINT ( '#', DEGP                               )
         CALL SIGERR ( 'SPICE(INVALIDDEGREE)'                  )
         CALL CHKOUT ( 'CHBIGR'                                )
         RETURN

      END IF

C
C     Check the radius of the domain interval.
C
      IF ( X2S(2) .LE. 0.D0 )  THEN

         CALL CHKIN  ( 'CHBIGR'                            )
         CALL SETMSG ( 'Interval radius must be positive '
     .   //            'but was #.'                        )
         CALL ERRDP  ( '#', X2S(2)                         )
         CALL SIGERR ( 'SPICE(INVALIDRADIUS)'              )
         CALL CHKOUT ( 'CHBIGR'                            )
         RETURN

      END IF

      NTERMS = DEGP + 1

C
C     Background
C     ==========
C
C
C     Let
C
C        T ,  n = 0, ...
C         n
C
C     represent the nth Chebyshev polynomial of the first kind:
C
C        T (x) = cos( n*arccos(x) )
C         n
C
C     These polynomials satisfy the recurrence relationship
C
C        T   (x) = 2x T (x)  -  T   (x),  n = 2, ...
C         n+1          n         n-1
C
C     The Chebyshev polynomials of the second kind are denoted by
C
C        U ,  n = 0, ...
C         n
C
C     where
C
C        U (x) = 1
C         0
C
C        U (x) = 2x
C         1
C
C        U   (x) = 2x U (x)  -  U   (x),  n = 2, ...
C         n+1          n         n-1
C
C
C     The integration formula (1) below is based on several
C     identities:
C
C
C        T (x)        = (1/2) * ( U (x) - U   (x) ),  n = 2, ...    (B1)
C         n                        n       n-2
C
C
C        d(T (x))/dx  =  n U   (x),   n = 1, ...                    (B2)
C           n               n-1
C
C
C                                 d(T   (x))/dx   d(T   (x))/dx
C                                    n+1             n-1
C        T (x)        = (1/2) * ( ------------- - ------------- ),
C         n                             n+1             n-1
C
C                                     n = 2, ...                    (B3)
C
C
C     Identity (B1) can be proved via mathematical induction. Using
C     (B1) and the Chebyshev recurrence formulas for both kinds of
C     polynomials, identity (B2) can also be proved via mathematical
C     induction. Identity (B3) follows directly from the combination of
C     (B1) and (B2).
C
C     Formula (1) below follows from (B3).
C
C
C     Algorithm
C     =========
C
C     In the discussion below, all Chebyshev polynomials are of the
C     first kind.
C
C     Let the notation
C
C        I( f )
C
C     represent the indefinite integral of a function f.
C
C     The key formula we use below is
C
C                              T          T
C                               n+1        n-1
C        I ( T  ) = (1/2) * ( ------  -  ------ )  +  C,  for n > 1  (1)
C             n                 n+1        n-1
C
C     where C is a constant of integration. Applying (1) to a Chebyshev
C     expansion
C
C               N+1
C               __
C               \
C        f(x) = /  a  T   (x)                                        (2)
C               --  k  k-1
C               k=1
C
C     we have
C
C                               N+1
C                               __       T (x)    T   (x)
C                               \         k        k-2
C        I( f(x) ) =      (1/2) /  a (   ------ - -------  )
C                               --  k       k       k-2
C                               k=3
C
C                    + a T (x) + ( a  / 4 ) T (x) + C ,   for N > 1 (3a)
C                       1 1         2        2       0
C
C     or
C
C        I( f(x) ) = C  + a T (x),   for N = 1                      (3b)
C                     0    1 1
C
C     where
C
C        C
C         0
C
C     is a constant of integration. Then by grouping coefficients of
C     the Chebyshev polynomials, we have
C
C
C                           N+2
C                           __
C                           \
C        I( f(x) ) = C  +   /  A  T   (x),  for N >= 0               (4)
C                     0     --  k  k-1
C                           k=2
C
C     where
C
C        A    = a   -  (1/2)a           for N >= 2,    or
C         2      1           3
C
C        A    = a                       for N <= 1                  (5a)
C         2      1
C
C                 1
C        A    = ------ ( a  -  a    )   for k = 3, ... , N (N>=3)   (5b)
C         k     2(k-1)    k-1   k+1
C
C                1
C        A    = ---- a                  for N >= 2                  (5c)
C         N+1    2N   N
C
C                 1
C        A    = ------ a                for N >= 1                  (5d)
C         N+2   2(N+1)  N+1
C
C
C     Note that (5b) does not conflict with (5c) or (5d) for N < 3,
C     since (5b) is applicable only when N >= 3.
C
C
C     We'll compute the sums
C
C                           N+2
C                           __
C                           \
C        I( f(x) ) - C  =   /  A  T   (x)                            (6)
C                     0     --  k  k-1
C                           k=2
C
C               N+2
C               __
C               \
C        C  = - /  A  T   (0)                                        (7)
C         0     --  k  k-1
C               k=2
C
C     and
C
C               N+1
C               __
C               \
C        f(x) = /  a  T   (x)
C               --  k  k-1
C               k=1
C
C
C     using Clenshaw's recurrence formula. Note that in the above
C     equations, N is the degree of the input expansion, which is
C     given by the input argument DEGP.
C
C     Transform the independent variable X to the interval
C
C        [-1, 1]
C
C     Call the result S.
C
C     Note we've already checked that X2S(2) is positive.
C
      S     = (X-X2S(1)) / X2S(2)
      S2    = 2.0D0 * S

C
C     Pre-compute the coefficients of the integral expansion
C     that are known at this point. The terms A2, ADEGP1, and
C     ADEGP2 correspond to the variables
C
C        A , A   , A
C         2   N+1   N+2
C
C     above and are set according to equations 5a, 5c, and 5d.
C
      IF ( NTERMS .GE. 3 ) THEN

         A2 = CP(1) - 0.5D0*CP(3)
      ELSE
         A2 = CP(1)
      END IF

C
C     Initialize the two highest-indexed coefficients of
C     the integral expansion.
C
      ADEGP1 = 0.D0
      ADEGP2 = 0.D0

      IF ( DEGP .GE. 2 ) THEN

         ADEGP1 = 0.5D0 * CP(DEGP) / DEGP

      END IF

      IF ( DEGP .GE. 1 ) THEN

         ADEGP2 = 0.5D0 * CP(DEGP+1) / (DEGP+1)

      END IF

C
C     The three quantities we'll compute require different numbers of
C     loop iterations: the integrals at X and at 0 require that I be
C     initialized to DEGP+2, while the input expansion requires that I
C     be initialized to DEGP+1. Since we wish to save on loop overhead
C     by performing the respective loop body actions in parallel, we
C     perform the integral computations for I = DEGP+2 prior to the
C     start of the loop.
C
C     Since F(1) and F(2) would normally be initialized to 0 prior to
C     the start of the loop, after the first loop pass, F would have
C     the contents assigned below.
C
      F(3) = 0.D0
      F(2) = 0.D0
C
C     The initial value of F(1) is the highest-order coefficient of
C     the integral's expansion.
C
      IF ( DEGP .EQ. 0 ) THEN
         F(1) = A2
      ELSE
         F(1) = ADEGP2
      END IF
C
C     We also want to evaluate [I(f)](0); we'll use this to
C     make the integral 0 at x = 0. We'll use the terms
C     Z(*) to evaluate the expansion of the integral at x = 0.
C
      Z(3) = 0.D0
      Z(2) = 0.D0
      Z(1) = F(1)
C
C     We'll use the terms W(*) to evaluate the input expansion.
C
      W(1) = 0.D0
      W(2) = 0.D0

C
C     NTERMS is DEGP+1.
C
      I = NTERMS

      DO WHILE ( I .GT. 1 )
C
C        The variable AI represents A(I), which is the Ith coefficient
C        of the Chebyshev expansion of the indefinite integral. AI is
C        set according to formulas 5a-c above.
C
         IF ( I .EQ. 2 ) THEN

            AI = A2

         ELSE IF ( I .LT. NTERMS ) THEN
C
C           AI is A ; I >= 3; DEGP >= 3.
C                  I
C
            AI = 0.5D0 * ( CP(I-1) - CP(I+1) ) / (I-1)

         ELSE
C
C           AI is A      ; I = NTERMS.
C                  DEGP+1
C
            AI = ADEGP1

         END IF

         F(3) = F(2)
         F(2) = F(1)
         F(1) = AI     + ( S2*F(2)  - F(3) )

         Z(3) = Z(2)
         Z(2) = Z(1)
         Z(1) = AI     - Z(3)

         W(3) = W(2)
         W(2) = W(1)
         W(1) = CP(I)  + ( S2*W(2)  - W(3) )

         I    = I - 1

      END DO

C
C     C0 is the negative of the input expansion evaluated at x=0, and
C     that expansion value is
C
C        0*Z(1) - Z(2)
C
C     The other terms are computed as in CHBINT.
C
      C0      =                    Z(2)
      ITGRLP  = C0    +   S*F(1) - F(2)
      P       = CP(1) + ( S*W(1) - W(2) )

C
C     Scale the integral to account for the change of variables
C     (from the original domain to [-1,1]). The scale factor is
C
C        dX/dS = X2S(2)
C
      ITGRLP = X2S(2) * ITGRLP

      RETURN
      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework