text:
C$Procedure      FNDUCV ( Find unit, class and value. )

      SUBROUTINE FNDUCV ( UNIN, KNOWN, CLASS, VALUE )
      IMPLICIT NONE

C$ Abstract
C
C     Find the class (length, time, angle, mass, charge) and value of
C     1 unit relative to the reference set of units ( radian, km, sec,
C     kg, coulomb).
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     CONSTANTS
C     CONVERSION
C     PARSING
C     UNITS
C     UTILITY
C
C$ Declarations

      CHARACTER*(*)         UNIN
      LOGICAL               KNOWN
      INTEGER               CLASS
      DOUBLE PRECISION      VALUE

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     UNIN       I   string that may be a primitive unit.
C     KNOWN      O   indicates whether UNIN was recognized.
C     CLASS      O   type of unit (angle, time, length, mass, charge).
C     VALUE      O   the number of these units in 1 reference unit.
C
C$ Detailed_Input
C
C     UNIN       is a string that may be a number or one of the
C                primitive units of angle, time, length, mass or
C                charge.  A list of recognized units are given below.
C                The case of UNIN (upper or lower) is insignificant.
C
C$ Detailed_Output
C
C     KNOWN      is true if UNIN is recognized as a primitive unit,
C                or number.  Otherwise it is .FALSE.
C
C     CLASS      is the type of UNIN if it is recognized.  The class
C                values are:
C
C                   0  for a number
C                   1  for an angle
C                   2  for length
C                   3  for time
C                   4  for mass
C                   5  for charge
C
C                if UNIN is not recognized as belonging to any of these
C                classes, CLASS is assigned the value of -1.
C
C     VALUE      is the value of 1 UNIN in reference units.
C                The reference units are:
C
C                   Number           1
C                   Angle            radians
C                   length           kilometers
C                   time             second
C                   mass             kilogram
C                   charge           coulomb
C
C                if UNIN is not recognized as belonging to any of these
C                classes, VALUE is set to 0.0d0.
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) This routine is NOT case sensitive.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine examines UNIN and determines if it is a number or
C     recognized unit of angle, length, time, mass or charge.  If
C     it is recognized it sets a logical variable to .TRUE. to
C     indicate the recognition.  In addition, it returns the type of
C     object as an integer code: 0 for number, 1 for angle,
C     2 for length, 3 for time and 5 for charge.  Finally it returns
C     the number of fundamental units 1 UNIN is equal to.  The
C     fundamental units for each class of object are:
C
C        number  ---  1
C        angle   ---  radians
C        length  ---  kilometers
C        time    ---  seconds
C        mass    ---  kilograms
C        charge  ---  coulombs
C
C      The routine does not recognize any compound units such as
C      newtons or joules.
C
C$ Examples
C
C      This routine is intended primarily as a utility routine for
C      a more general units conversion routine.
C
C$ Restrictions
C
C      None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 24-MAY-1991 (WLT)
C
C-&

C
C     SPICELIB Functions
C
      DOUBLE PRECISION      CLIGHT
      DOUBLE PRECISION      PI
      DOUBLE PRECISION      TWOPI
      INTEGER               BSRCHC
      LOGICAL               BENUM

C
C
C     Local parameters
C
      INTEGER               USIZE
      PARAMETER           ( USIZE = 32 )

      INTEGER               NUNITS
      PARAMETER           ( NUNITS = 84 )

C
C     These are the various classes of recognized objects.
C
      INTEGER               NUMBER
      PARAMETER           ( NUMBER = 0 )

      INTEGER               ANGLE
      PARAMETER           ( ANGLE  = 1 )

      INTEGER               LENGTH
      PARAMETER           ( LENGTH = 2 )

      INTEGER               TIME
      PARAMETER           ( TIME   = 3 )

      INTEGER               MASS
      PARAMETER           ( MASS   = 4 )

      INTEGER               CHARGE
      PARAMETER           ( CHARGE = 5 )

C
C     The reference values for length will be kilometers
C                          for time   will be seconds
C                          for angles will be radians
C                          for mass   will be kilograms
C                          for charge will be coulombs
C
      DOUBLE PRECISION      KM
      PARAMETER           ( KM = 1.0D0 )

      DOUBLE PRECISION      METER
      PARAMETER           ( METER = 0.001D0 * KM )

      DOUBLE PRECISION      CM
      PARAMETER           ( CM = 0.01D0 * METER )

      DOUBLE PRECISION      MM
      PARAMETER           ( MM = 0.1D0 * CM     )

      DOUBLE PRECISION      INCH
      PARAMETER           ( INCH = 2.54D0 * CM )

      DOUBLE PRECISION      FOOT
      PARAMETER           ( FOOT = 12.0D0 * INCH )

      DOUBLE PRECISION      YARD
      PARAMETER           ( YARD = 3.0D0 * FOOT )

      DOUBLE PRECISION      MILEST
      PARAMETER           ( MILEST = 5280.0D0 * FOOT )

      DOUBLE PRECISION      MILENT
      PARAMETER           ( MILENT = 1852.0D0 * METER )

      DOUBLE PRECISION      AU
C
C     This value will be computed at run time or default to the
C     value given here.
C

      DOUBLE PRECISION      DE200V
      PARAMETER           ( DE200V = 1.4959787066D8  )
C
C      Some of the units are not "defined" quantities.  In such a case
C      a best estimate is provided as of the date of the current version
C      of this routine.  Those estimated quantities are:
C
C         1 AU    --- the astronomical unit  is taken from the JPL
C                     ephemeris DE200.  It is believed to be accurate to
C                     about 40 meters.
C
C         The tropical year is the time from equinox to equinox.  This
C         varies slightly with time.
C
C         1 PARSEC --- is dependent upon the value of the astronomical
C                      unit.
C
C
C     1.0d0 divided by the sin of 1 arc second
C
      DOUBLE PRECISION      SCALE

      DOUBLE PRECISION      PARSEC

      DOUBLE PRECISION      SECOND
      PARAMETER           ( SECOND = 1.0D0 )

      DOUBLE PRECISION      MINUTE
      PARAMETER           ( MINUTE = 60.0D0 * SECOND )

      DOUBLE PRECISION      HOUR
      PARAMETER           ( HOUR = 60.0D0 * MINUTE )

      DOUBLE PRECISION      DAY
      PARAMETER           ( DAY = 24.0D0 * HOUR )

      DOUBLE PRECISION      WEEK
      PARAMETER           ( WEEK = 7.0D0 * DAY )

      DOUBLE PRECISION      JYEAR
      PARAMETER           ( JYEAR = 365.25D0 * DAY )

      DOUBLE PRECISION      TYEAR
      PARAMETER           ( TYEAR = DAY * 365.2421988D0 )

      DOUBLE PRECISION      JCENT
      PARAMETER           ( JCENT = 100.0D0 * JYEAR )

      DOUBLE PRECISION      RADIAN
      PARAMETER           ( RADIAN = 1.0D0 )

      DOUBLE PRECISION      MILRAD
      PARAMETER           ( MILRAD = 0.001D0 * RADIAN )

      DOUBLE PRECISION      MICRAD
      PARAMETER           ( MICRAD = 0.001D0 * MILRAD )

      DOUBLE PRECISION      NANRAD
      PARAMETER           ( NANRAD = 0.001D0 * MICRAD )

      DOUBLE PRECISION      KG
      PARAMETER           ( KG = 1.0D0 )

      DOUBLE PRECISION      GRAM
      PARAMETER           ( GRAM = 0.001D0*KG )

      DOUBLE PRECISION      POUND
      PARAMETER           ( POUND = 0.45359237D0 * KG )

      DOUBLE PRECISION      OUNCE
      PARAMETER           ( OUNCE = POUND / 16.0D0 )

      DOUBLE PRECISION      COULOM
      PARAMETER           ( COULOM = 1.0D0 )

      DOUBLE PRECISION      ECHARG
      PARAMETER           ( ECHARG = COULOM / 6.24196D18 )

      DOUBLE PRECISION      STATCL
      PARAMETER           ( STATCL = COULOM * 2.997930D9 )

C
C     Local variables
C
      CHARACTER*(USIZE)     CANDS
      CHARACTER*(USIZE+1)   CANDP
      CHARACTER*(USIZE)     ERROR

      DOUBLE PRECISION      DEGREE
      DOUBLE PRECISION      ARCMIN
      DOUBLE PRECISION      ARCSEC
      DOUBLE PRECISION      HRANG
      DOUBLE PRECISION      LIGHT
      DOUBLE PRECISION      LSEC
      DOUBLE PRECISION      LMIN
      DOUBLE PRECISION      LHOUR
      DOUBLE PRECISION      LDAY
      DOUBLE PRECISION      LYEAR
      DOUBLE PRECISION      MINANG
      DOUBLE PRECISION      REV
      DOUBLE PRECISION      SECANG

      INTEGER               COUNT
      INTEGER               I
      INTEGER               J
      INTEGER               PTR
      CHARACTER*(8)         NAMES  ( 1 )
      LOGICAL               UPDATE
      LOGICAL               FOUND
      INTEGER               IAU
      INTEGER               IAUS
      INTEGER               IPARSC
      INTEGER               NNAMES

C
C     Conversion values.
C
      CHARACTER*(USIZE)     UNITS  ( NUNITS )
      INTEGER               UCLASS ( NUNITS )
      DOUBLE PRECISION      UVALUE ( NUNITS )
      INTEGER               ORDVEC ( NUNITS )
      LOGICAL               FIRST
      SAVE

C
C     Initial values
C
      DATA                  FIRST   / .TRUE. /

C
C     This next block of code sets up the constants, names, values
C     and classes for all the recognized strings.  We do this here
C     because FORTRAN just doesn't do this kind of stuff in a
C     convenient manner.
C
      IF ( FIRST ) THEN

         FIRST = .FALSE.

         DEGREE = PI()   / 180.0D0
         ARCMIN = DEGREE / 60.0D0
         ARCSEC = ARCMIN / 60.0D0
         SCALE  = 1.0D0  / DSIN ( ARCSEC )

         SECANG = ARCSEC * 15.0D0
         MINANG = ARCMIN * 15.0D0
         HRANG  = DEGREE * 15.0D0

         REV    = TWOPI()

         LIGHT  = CLIGHT()
         LSEC   = SECOND * LIGHT
         LMIN   = MINUTE * LIGHT
         LHOUR  = HOUR   * LIGHT
         LDAY   = DAY    * LIGHT
         LYEAR  = JYEAR  * LIGHT

         NNAMES   = 1
         NAMES(1) = 'AU'

C
C        If available and the value of the AU is reasonable, we fetch
C        it from the kernel pool.  Otherwise we use the value in
C        DE200.
C
         CALL SWPOOL ( 'FNDUCV', NNAMES, NAMES  )
         CALL CVPOOL ( 'FNDUCV',         UPDATE )
         CALL RTPOOL ( 'AU',     I,  AU, FOUND  )

         IF ( .NOT. FOUND ) THEN

            AU = DE200V

         ELSE IF ( DABS( AU - DE200V ) .GT. 10.0D0 ) THEN

            AU = DE200V

         END IF

         PARSEC = SCALE * AU

         I = 0

         I         = I + 1
         UNITS(I)  = 'METERS'
         UVALUE(I) =  METER
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'CM'
         UVALUE(I) =  CM
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'KM'
         UVALUE(I) =  KM
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'KMS'
         UVALUE(I) =  KM
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'CENTIMETERS'
         UVALUE(I) =  CM
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'KILOMETERS'
         UVALUE(I) =  KM
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'INCH'
         UVALUE(I) =  INCH
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'INCHES'
         UVALUE(I) =  INCH
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'FOOT'
         UVALUE(I) =  FOOT
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'FEET'
         UVALUE(I) =  FOOT
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'YARDS'
         UVALUE(I) =  YARD
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'AU'
         UVALUE(I) =  AU
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'AUS'
         UVALUE(I) =  AU
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'MILES'
         UVALUE(I) =  MILEST
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'STATUTE_MILES'
         UVALUE(I) =  MILEST
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'LIGHTSECONDS'
         UVALUE(I) =  LSEC
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'LIGHTYEAR'
         UVALUE(I) =  LYEAR
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'SECS'
         UVALUE(I) =  SECOND
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'SECONDS'
         UVALUE(I) =  SECOND
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'MINS'
         UVALUE(I) =  MINUTE
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'MINUTES'
         UVALUE(I) =  MINUTE
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'HRS'
         UVALUE(I) =  HOUR
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'HOURS'
         UVALUE(I) =  HOUR
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'DAYS'
         UVALUE(I) =  DAY
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'WEEKS'
         UVALUE(I) =  WEEK
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'JYEARS'
         UVALUE(I) =  JYEAR
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'JULIAN_YEARS'
         UVALUE(I) =  JYEAR
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'CENTURY'
         UVALUE(I) =  JCENT
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'CENTURIES'
         UVALUE(I) =  JCENT
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'JULIAN_CENTURIES'
         UVALUE(I) =  JCENT
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'JULIAN_CENTURY'
         UVALUE(I) =  JCENT
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'LIGHTDAYS'
         UVALUE(I) =  LDAY
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'LIGHTYEARS'
         UVALUE(I) =  LYEAR
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'RADIANS'
         UVALUE(I) =  RADIAN
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'MILLIRADIANS'
         UVALUE(I) = MILRAD
         UCLASS(I) = ANGLE

         I         = I + 1
         UNITS(I)  = 'MICRORADIANS'
         UVALUE(I) = MICRAD
         UCLASS(I) = ANGLE

         I         = I + 1
         UNITS(I)  = 'NANORADIANS'
         UVALUE(I) = NANRAD
         UCLASS(I) = ANGLE

         I         = I + 1
         UNITS(I)  = 'DEGREES'
         UVALUE(I) =  DEGREE
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'DEGS'
         UVALUE(I) =  DEGREE
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'ARCSECONDS'
         UVALUE(I) =  ARCSEC
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'ARCMINUTES'
         UVALUE(I) =  ARCMIN
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'SECONDANGLES'
         UVALUE(I) =  SECANG
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'MINUTEANGLES'
         UVALUE(I) =  MINANG
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'HOURANGLES'
         UVALUE(I) =  HRANG
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'KILOGRAMS'
         UVALUE(I) =  KG
         UCLASS(I) =  MASS

         I         = I + 1
         UNITS(I)  = 'KGS'
         UVALUE(I) =  KG
         UCLASS(I) =  MASS

         I         = I + 1
         UNITS(I)  = 'GRAMS'
         UVALUE(I) =  GRAM
         UCLASS(I) =  MASS

         I         = I + 1
         UNITS(I)  = 'POUNDS'
         UVALUE(I) =  POUND
         UCLASS(I) =  MASS

         I         = I + 1
         UNITS(I)  = 'OUNCES'
         UVALUE(I) =  OUNCE
         UCLASS(I) =  MASS

         I         = I + 1
         UNITS(I)  = 'PARSECS'
         UVALUE(I) =  PARSEC
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'YEARS'
         UVALUE(I) =  JYEAR
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'JULIANYEARS'
         UVALUE(I) =  JYEAR
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'TROPICALYEARS'
         UVALUE(I) =  TYEAR
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'TROPICAL_YEARS'
         UVALUE(I) =  TYEAR
         UCLASS(I) =  TIME

         I         = I + 1
         UNITS(I)  = 'STATUTEMILES'
         UVALUE(I) =  MILEST
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'NAUTICALMILES'
         UVALUE(I) =  MILENT
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'NAUTICAL_MILES'
         UVALUE(I) =  MILENT
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'MMS'
         UVALUE(I) =  MM
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'MILLIMETERS'
         UVALUE(I) =  MM
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'REVOLUTIONS'
         UVALUE(I) =  REV
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'REVS'
         UVALUE(I) =  REV
         UCLASS(I) =  ANGLE

         I         = I + 1
         UNITS(I)  = 'LIGHTHOURS'
         UVALUE(I) =  LHOUR
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'LIGHTMINUTES'
         UVALUE(I) =  LMIN
         UCLASS(I) =  LENGTH

         I         = I + 1
         UNITS(I)  = 'COULOMBS'
         UVALUE(I) =  COULOM
         UCLASS(I) =  CHARGE

         I         = I + 1
         UNITS(I)  = 'ELECTRON_CHARGES'
         UVALUE(I) =  ECHARG
         UCLASS(I) =  CHARGE

         I         = I + 1
         UNITS(I)  = 'STATCOULOMBS'
         UVALUE(I) =  STATCL
         UCLASS(I) =  CHARGE

         I         = I + 1
         UNITS(I)  = 'PI'
         UVALUE(I) =  PI()
         UCLASS(I) = NUMBER

         I         = I + 1
         UNITS(I)  = '-PI'
         UVALUE(I) =  -PI()
         UCLASS(I) = NUMBER
C
C        I         = I + 1
C        UNITS(I)  =
C        UVALUE(I) =
C        UCLASS(I) =
C
         COUNT = I

C
C        Sort everything for quick lookup.
C
         CALL ORDERC ( UNITS,  COUNT, ORDVEC )
         CALL REORDC ( ORDVEC, COUNT, UNITS  )
         CALL REORDD ( ORDVEC, COUNT, UVALUE  )
         CALL REORDI ( ORDVEC, COUNT, UCLASS  )

      END IF

      CALL CVPOOL ( 'FNDUCV', UPDATE )

      IF ( UPDATE ) THEN

         IAU    = BSRCHC ( 'AU',      COUNT, UNITS )
         IAUS   = BSRCHC ( 'AUS',     COUNT, UNITS )
         IPARSC = BSRCHC ( 'PARSECS', COUNT, UNITS )

         CALL RTPOOL ( 'AU', I, AU, FOUND )

         IF ( DABS(AU - DE200V) .LT. 10.0D0 ) THEN

            UVALUE(IAU)    = AU
            UVALUE(IAUS)   = AU
            UVALUE(IPARSC) = SCALE * AU

         END IF

      END IF

C
C     Left justify, convert to upper case and form a "plural" version
C     of UNIN
C
      CALL LJUST  ( UNIN,   CANDS )
      CALL UCASE  ( CANDS,  CANDS )

      CANDP =               CANDS
      CALL SUFFIX ( 'S', 0, CANDP )

C
C     Look for the "singular" version first.
C
      J = BSRCHC ( CANDS, COUNT, UNITS )

C
C     If we didn't have any luck with the singular version,
C     look for the plural form.
C
      IF ( J .EQ. 0 ) THEN
         J = BSRCHC ( CANDP, COUNT, UNITS )
      END IF

C
C     If we got something, just copy the class and value.
C
      IF ( J .GT. 0 ) THEN

         KNOWN = .TRUE.
         CLASS = UCLASS ( J )
         VALUE = UVALUE ( J )

      ELSE

C
C        We don't have a unit.  Get ready to return...
C
         KNOWN = .FALSE.
         CLASS = -1
         VALUE = 0.0D0

C
C        ... but before we do, see if we've got a number.
C
         IF ( BENUM ( CANDS ) ) THEN

            CALL NPARSD ( CANDS, VALUE, ERROR, PTR )

            IF ( ERROR .EQ. ' ' ) THEN
               KNOWN = .TRUE.
               CLASS = NUMBER
            END IF

         END IF

      END IF

C
C     Since the user can potentially enter a bad value for the AU
C     via the kernel pool, we will signal an error.  However we
C     wait until this point so that routines that need to have
C     an AU value in order to continue functioning,
C
      IF ( DABS(AU - DE200V) .GT. 10.0D0 ) THEN

         CALL CHKIN  ( 'FNDUCV' )
         CALL SETMSG ( 'The value of the astronomical unit '       //
     .                 'extracted from the kernel pool varies '    //
     .                 'from the well trusted value used in DE200 '//
     .                 '(149,597,870.660 km) by more than 10 km. ' //
     .                 'The value in DE200 is believed to be good '//
     .                 'to 60 meters or so.  The value in the '    //
     .                 'kernel pool was #. '                      )
         CALL ERRDP  ( '#',    AU                                 )
         CALL SIGERR ( 'SPICE(BADAUVALUE)'                        )
         CALL CHKOUT ( 'FNDUCV'                                   )
C
C        Reset the value of the AU back to the DE200 value so that
C        the next time we hit this without doing a kernel pool read
C        we will not get this error message again.
C
         AU = DE200V
         RETURN

      END IF

      RETURN
      END

ext: f

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
      SUBROUTINE loop3_F77(N, x, y, a)
      INTEGER i, N
      REAL*8 x(N), y(N), a

      DO i=1,N
          y(i) = y(i) + a*x(i);
      END DO
      RETURN
      END

      SUBROUTINE loop3_F77Overhead(N, x, y, a)
      INTEGER i, N
      REAL*8 x(N), y(N), a
      RETURN
      END

max_stars_repo_name: fraguela/depspawn

max_issues_repo_name: MSV-Project/IBAMR

max_forks_repo_name: MSV-Project/IBAMR


text:
        subroutine localy (global, rlocal, ientmp, n, code)
c
c----------------------------------------------------------------------
c
c This subroutine performs a vector gather/scatter operation.
c
c input:
c  global (nshg,n)              : global array
c  rlocal (npro,nshl,n)         : local array
c  ien    (npro,nshl)           : nodal connectivity
c  n                            : number of d.o.f.'s to be copied
c  code                         : the transfer code
c                                  .eq. 'gather  ', from global to local
c                                  .eq. 'scatter ', add  local to global
c                                  .eq. 'globaliz', from local to global
c
c
c Zdenek Johan, Winter 1992.
c----------------------------------------------------------------------
c
        include "common.h"

        dimension global(nshg,n),           rlocal(npro,nshl,n),
     &            ien(npro,nshl),           ientmp(npro,nshl)
c
        character*8 code

c
c.... cubic basis has negatives in ien
c
        if (ipord > 2) then
           ien = abs(ientmp)
        else
           ien = ientmp
        endif
c
c.... ------------------------>  'localization  '  <--------------------
c
        if (code .eq. 'gather  ') then
c
c.... set timer
c
c          call timer ('Gather  ')
c
c.... gather the data to the current block
c

CAD      rlocal = yl={P, u, v, w, T, scalar1, ...}
CAD	 global = y = {u, v, w, P, T, scalar1, ...}

CAD      Put u,v,w in the slots 2,3,4 of yl

          do j = 1, 3
            do i = 1, nshl
              rlocal(:,i,j+1) = global(ien(:,i),j)
            enddo
          enddo

CAD      Put Pressure in the first slot of yl

          do i = 1, nshl
             rlocal(:,i,1) = global(ien(:,i),4)
          enddo

CAD      Fill in the remaining slots with T, and additional scalars

          if(n.gt.4) then
             do j = 5, n
                do i = 1, nshl
                   rlocal(:,i,j) = global(ien(:,i),j)
                enddo
             enddo
          endif
c
c.... transfer count
c
          gbytes = gbytes + n*nshl*npro
c
c.... return
c
c          call timer ('Back    ')
          return
        endif
c
c.... ------------------------->  'assembling '  <----------------------
c
        if (code .eq. 'scatter ') then
           write(*,*) 'do not use localy here'
        endif
c
c.... ------------------------->  'globalizing '  <----------------------
c
        if (code .eq. 'globaliz') then
           write(*,*) 'do not use localy here'
        endif
c
c.... --------------------------->  error  <---------------------------
c
        call error ('local   ', code, 0)
c
c.... end
c
        end


program version
use M_attr, only : attr, attr_update, attr_mode
! shows a limitation if periods are replaced with spaces the CHAR= option does not
! count the colored blanks so if no text after the blanks too much padding is appended to the line
! need to count last character with a background attribute or something different
implicit none
integer :: i
!nvfortran bug!character(len=*),parameter :: text(*)= [character(len=132) :: &
character(len=*),parameter :: text(23)= [character(len=132) :: &
'<E><e>                                                     ',&
'<E><e>        <C>                                   </W><E><end>',&
'<E><e>        <C>      LLL        </C><E> <bo><w>F</bo>ortran   </w></E><C>       <E><e></bo><end>',&
'<E><e>        <C>     LL LL       </C><E>  <bo><w>P</bo>ackage  </w></E><C>       <E><e></bo><end>',&
'<E><e>        <C>     LL          </C><E>   <bo><w>M</bo>anager </w></E><C>       <E><e></bo><end>',&
'<E><e>        <C>   LLLLLL                          <E><end>',&
'<E><e>        <C>     LL                            <E><end>',&
'<E><e>        <C>     LL               LLLLL LLL    <E><end>',&
'<E><e>        <C>     LL     LLLLLL     LL  L  LL   <E><end>',&
'<E><e>        <C>     LL    LL     L    LL  L  LL   <E><end>',&
'<E><e>        <C>     LL    LL     L    LL  L  LL   <E><end>',&
'<E><e>        <C>     LL    LLLLLLL     LL  L  LL   <E><end>',&
'<E><e>        <C>           LL                      <E><end>',&
'<E><e>        <C>           LL                      <E><end>',&
'<E><e>        <C>           LL                      <E><end>',&
'<E><e>        <C>                                   <E><end>',&
'<E><e>                                                     ',&
'<E><bo>Program:<w>     fpm(1)                                     ',&
'<E><bo>Description:<w> A Fortran package manager and build system ',&
'<E><bo>Version:<w>     0.3.0, alpha                               ',&
'<E><bo>License:<w>     MIT                                        ',&
'<E><bo>Home Page:<w>   https://github.com/fortran-lang/fpm        ',&
'<E><bo>']
   ! add custom keywords
   call attr_update('end','.',' ')
   call attr_mode(manner='plain')
   write(*,'(a)')(attr(trim(text(i)),chars=80),i=1,size(text))
   call attr_update('end','.',char(0))
   call attr_mode(manner='color')
   write(*,'(a)')(attr(trim(text(i)),chars=80),i=1,size(text))
end program version


text:
C--------------------------------------------------------------------
C The user of the OPEN-ADAS system and data (hereinafter "the User")
C accepts the following terms and conditions:
C
C   1. The University of Strathclyde uses all reasonable endeavours
C      to ensure the accuracy of the data provided and any
C      information given, but the University makes no warranty,
C      expressed or implied as to its accuracy, integrity, fitness
C      for purpose and shall not be responsible for the use to
C      which the data is put by the User and/or any consequences
C      arising out of any inaccuracies or omissions.
C
C   2. Any downloaded OPEN-ADAS file is made available here for the
C      personal use of the User only.  It must not be used for any
C      commercial application, incorporated into any web site or in
C      any form re-distributed without express prior written
C      permission from the ADAS Project. In particular, but not by
C      way of limitation, it must not be:
C
C        * inserted into a managed database structure
C        * redistributed along with a modelling or analysis code
C        * made available on a public website.
C
C Permission for OPEN-ADAS data incorporation in non-commercial
C code/system development for scientific advance will not be
C unreasonably withheld, but will be subject to written agreement
C on a case by case basis.
C
C The User will indemnify the University of Strathclyde and keep
C it fully and effectively indemnified against each and every
C claim made against the University as a result of the User's
C use of the data.
C--------------------------------------------------------------------
       subroutine xxdata_15( iunit  , dsname ,
     &                       nstore , ntdim  , nddim  ,
     &                       ndptnl , ndptn  , ndptnc , ndcnct ,
     &                       ndstack, ndcmt ,
     &                       iz0    , is     , is1    , esym   ,
     &                       nptnl  , nptn   , nptnc  ,
     &                       iptnla , iptna  , iptnca ,
     &                       ncnct  , icnctv ,
     &                       ncptn_stack     , cptn_stack      ,
     &                       lres   , lptn   , lcmt   , lsup   ,
     &                       nbsel  , isela  ,
     &                       cwavel , cfile  , ctype  , cindm  ,
     &                       wavel  , ispbr  , isppr  , isstgr , iszr  ,
     &                       ita    , ida    ,
     &                       teta   , teda   ,
     &                       pec    , pec_max,
     &                       ncmt_stack      , cmt_stack
     &                     )
       implicit none
c-----------------------------------------------------------------------
c
c  ***************** fortran77 subroutine: xxdata_15 *******************
c
c  purpose:  To fetch  data  from  an input photon emissivity file
c            for a given emitting element superstage .
c
c  data:    Up to 'nstore' sets (data-blocks) of data may be  read from
c           the file - each block forming a complete set of photon
c           emissivity coefft. values for given temp/density grid.
c           Each data-block  is  analysed independently of any  other
c           datablock.
c
c           the units used in the data file are taken as follows:
c
c           temperatures : ev
c           densities    : cm-3
c           pec          : phot. cm3 s-1
c
c  subroutine:
c
c  input : (i*4)  iunit    = unit to which input file is allocated.
c          (i*4)  dsname   = name of opened data set on iunit
c
c          (i*4)  nstore   = maximum number  of  input data-blocks  that
c                            can be stored.
c          (i*4)  ntdim    = max number of electron temperatures allowed
c          (i*4)  nddim    = max number of electron densities    allowed
c          (i*4)  ndptnl   = maximum level of partitions
c          (i*4)  ndptn    = maximum no. of partitions in one level
c          (i*4)  ndptnc   = maximum no. of components in a partition
c          (i*4)  ndcnct   = maximum number of elements in connection
c          (i*4)  ndstack  = maximum number of partition text lines
c          (i*4)  ndcmt    = maximum number of comment text lines
c                             vector
c output:  (i*4)  iz0      = read - emitting ion - nuclear charge
c          (i*4)  is       = read - emitting ion - charge
c                            (generalised to superstage label)
c          (i*4)  is1      = read - emitting ion - charge + 1
c                            (generalised to superstage index= is + 1)
c          (c*2)  esym     = read - emitting ion - element symbol
c
c          (i*4)  nptnl    = number of partition levels in block
c          (i*4)  nptn()   = number of partitions in partition level
c                            1st dim: partition level
c          (i*4)  nptnc(,) = number of components in partition
c                            1st dim: partition level
c                            2nd dim: member partition in partition level
c          (i*4)  iptnla() = partition level label (0=resolved root,1=
c                                                     unresolved root)
c                            1st dim: partition level index
c          (i*4)  iptna(,) = partition member label (labelling starts at 0)
c                            1st dim: partition level index
c                            2nd dim: member partition index in partition
c                            level
c          (i*4)  iptnca(,,)= component label (labelling starts at 0)
c                            1st dim: partition level index
c                            2nd dim: member partition index in partition
c                            level
c                            3rd dim: component index of member partition
c          (i*4)  ncnct     = number of elements in connection vector
c          (i*4)  icnctv()  = connection vector of number of partitions
c                             of each superstage in resolved case
c                             including the bare nucleus
c                             1st dim: connection vector index
c          (i*4)  ncptn_stack = number of text lines in partition block
c          (c*80) cptn_stack()= text lines in partition block
c                               1st dim: text line index (1->ncptn_stack)
c
c          (l*4)  lres      = .true.  => partial file
c                           = .false. => not partial file
c          (l*4)  lptn      = .true.  => partition block present
c                           = .false. => partition block not present
c          (l*4)  lcmt      = .true.  => comment text block present
c                           = .false. => comment text block not present
c          (l*4)  lsup      = .true.  => ss use of filmem field
c                           = .false. => old use of filmem field
c
c          (i*4)  nbsel     = number of data-blocks accepted & read in.
c          (i*4)  isela()   = read - data-set data-block entry indices
c                            dimension: data-block index
c
c          (c*10) cwavel() = wavelength string (angstroms)
c                            1st dim: data-block index
c          (c*8)  cfile()  = specific ion file source string in older
c                            forms.  Field not present in superstage
c                            version, but reused for added information
c                            1st dim: data-block index
c          (c*8)  ctype()  = data type string
c                            1st dim: data-block index
c          (c*2)  cindm()  = metastable index string
c                            1st dim: data-block index
c
c          (r*8)  wavel()   = wavelength (angstroms)
c                             dimension: data-block index
c          (i*4)  isppr()   = parent index for each line block
c                             1st dim: index of block in adf15 file
c          (i*4)  ispbr()   = base index for each line block
c                             1st dim: index of block in adf15 file
c          (i*4)  isstgr()  = s1 for each resolved data block
c                             1st dim: index of block in adf15 file
c          (i*4)  iszr()    = ion charge relating to each line
c                             1st dim: index of block in adf15 file
c
c          (i*4)  ita()     = number of electron temperatures
c                             dimension: data-block index
c          (i*4)  ida()     = read - number of electron densities
c                             1st dim: data-block index
c
c          (r*8)  teta(,)   =  electron temperatures (units: ev)
c                             1st dim: electron temperature index
c                             2nd dim: data-block index
c          (r*8)  teda(,)   = electron densities (units: cm-3)
c                             1st dim: electron density index
c                             2nd dim: data-block index
c
c          (r*8)  pec(,,)   = photon emissivity coeffts
c                             1st dim: electron temperature index
c                             2nd dim: electron density index
c                             3rd dim: data-block index
c          (r*8)  pec_max() = photon emissivity coefft. maximum
c                             as a function of Te at first Ne value
c                             1st dim: data-block index
c          (i*4)  ncmt_stack = number of text lines in comment block
c          (c*80) cmt_stack()= text lines in comment block
c                               1st dim: text line index (1->ncmt_stack)
c
c routine: (i*4)  i4eiz0   = function - (see routines section below)
c          (i*4)  i4fctn   = function - (see routines section below)
c          (i*4)  i4unit   = function - (see routines section below)
c          (i*4)  iblk     = array index: data-block index
c          (i*4)  itt      = array index: electron temperature index
c          (i*4)  itd      = array index: electron density     index
c          (i*4)  ntnum    = number of electron temperatures for current
c                            data-block
c          (i*4)  ndnum    = number of electron densities    for current
c                            data-block
c          (i*4)  iabt     = return code from 'i4fctn'
c          (i*4)  ipos1    = general use string index variable
c          (i*4)  ipos2    = general use string index variable
c
c          (l*4)  lbend    = identifies whether the last of the  input
c                            data sub-blocks has been located.
c                            (.true. => end of sub-blocks reached)
c
c          (c*1)  cslash   = '/' - delimiter for 'xxhkey'
c          (c*2)  c2       = general use two byte character string
c          (c*5)  ionnam   = emitting ion read from dataset
c          (c*6)  ckey1    = 'filmem' - input block header key
c          (c*4)  ckey2    = 'type  ' - input block header key
c          (c*4)  ckey3    = 'indm  ' - input block header key
c          (c*4)  ckey4    = 'isel  ' - input block header key
c          (c*80) c80      = general use 80 byte  character  string  for
c                            the input of data-set records.
c
c routines:
c          routine    source    brief description
c          ------------------------------------------------------------
c          i4eiz0     adas      returns z0 for given element symbol
c          i4fctn     adas      convert character string to integer
c          i4unit     adas      fetch unit number for output of messages
c          r8fctn     adas      convert string to real number
c          xxmkrp     adas      make up root partition text lines
c          xxcase     adas      convert a string to upper or lower case
c          xxhkey     adas      obtain key/response strings from text
c          xxrptn     adas      analyse an adf11 file partition block
c          xxword     adas      extract position of number in buffer
c          xxslen     adas      find string less front and tail blanks
c
c author:  H. P. Summers
c          k1/1/57
c          jet ext. 4941
c
c date:    11/10/91
c
c update:  05/12/91 - PE Briden: ionnam now allowed to occupy either
c                                4 or 5 spaces in the header.
c
c update:  23/04/93 - PE Briden - adas91: added i4unit function to write
c                                         statements for screen messages
c
c update:  24/05/93 - PE Briden - adas91: changed i4unit(0)-> i4unit(-1)
c
c update:  27/2/95  - L. Jalota - idl_adas : increased size dsname for
c                                            use under unix systems
c
c unix-idl port:
c
c version: 1.2                          date: 23-1-96
c modified: Tim Hammond (tessella support services plc)
c               - corrected format statements for dsname length
c
c-----------------------------------------------------------------------
c
c
c notes: copied from e3data.for. this is v1.1 of xxdata_15.
c
c
c version  : 1.1
c date     : 12-04-2005
c modified : Martin o'Mullane
c              - first version
c
c version  : 1.2
c date     : 25-04-2005
c modified : Martin o'Mullane
c              - increase c3 to character*3 to permit more than
c                100 entries in adf15 file.
c
c version  : 1.3
c date     : 15-05-2006
c modified : Hugh Summers
c              - extended to operation with superstages and partitions.
c
c version  : 1.4
c date     : 03-01-2007
c modified : Hugh Summers
c               - remove redundant variables.
c
c-----------------------------------------------------------------------
      integer    idword    , idcnct  , iz0_max_res
c-----------------------------------------------------------------------
      parameter ( idword = 256 , idcnct = 100 )
      parameter ( iz0_max_res = 10 )
c-----------------------------------------------------------------------
      integer    i4eiz0    , i4fctn   , i4unit
      integer    iunit     , nstore   ,
     &           ntdim     , nddim    ,
     &           iz0       , is       ,
     &           is1       , nbsel
      integer    iblk      ,
     &           itt       , itd      ,
     &           ntnum     , ndnum    ,
     &           ipos1     , ipos2    , iabt
      integer    ndptnl    , ndptn    , ndptnc        , ndcnct
      integer    ndstack   , ndcmt
      integer    nptnl     , ncnct    , ncptn_stack   , ncmt_stack  ,
     &           iptnl
      integer    nfirst    , iwords   , nwords
      integer    i         , j        , ifirst        , ilast
      integer    max_indm  , indm
c-----------------------------------------------------------------------
      real*8     pmax      , r8fctn
c-----------------------------------------------------------------------
      logical    lbend
      logical    lptn      , lresol   , lres    , lsup
      logical    lcmt      , lptn_temp
c-----------------------------------------------------------------------
      character  dsname*80             , esym*2
      character  cslash*1              , colon*1
      character  c2*2                  , c3*3                ,
     &           ckey1*6               , ckey2*4             ,
     &           ckey3*4               , ckey4*4             ,
     &           ckey5*2               , ckey6*2             ,
     &           ckey7*2               , ckey8*2             ,
     &           ckey9*2               , ckey10*4            ,
     &           ckey11*4              ,
     &           ionnam*5              , c80*80              , cstrg*80
      character  cblnk8*8
c-----------------------------------------------------------------------
      integer    isela(nstore)         ,
     &           ita(nstore)           , ida(nstore)
      integer    nptn(ndptnl)          , nptnc(ndptnl,ndptn)
      integer    iptnla(ndptnl)        , iptna(ndptnl,ndptn)
      integer    iptnca(ndptnl,ndptn,ndptnc)
      integer    icnctv(ndcnct)
      integer    ifirsta(idword)       , ilasta(idword)
      integer    isstgr(nstore)        , iszr(nstore)
      integer    ispbr(nstore)         , isppr(nstore)
      integer    ncncta(iz0_max_res)   , icnctva(iz0_max_res,idcnct)
c-----------------------------------------------------------------------
      character  cindm(nstore)*2       , cfile(nstore)*8      ,
     &           ctype(nstore)*8       , cwavel(nstore)*10
      character  cptn_stack(ndstack)*80,cmt_stack(ndcmt)*80
c-----------------------------------------------------------------------
      real*8     teta(ntdim,nstore)    , teda(nddim,nstore)
      real*8     wavel(nstore)         , pec(ntdim,nddim,nstore)
      real*8     pec_max(nstore)
c-----------------------------------------------------------------------
      save       cslash                ,
     &           ckey1                 , ckey2                ,
     &           ckey3                 , ckey4
c-----------------------------------------------------------------------
      data       cslash / '/' /        , colon  / ':' /
      data       cblnk8 /'        '/
      data       ckey1  / 'filmem' /   , ckey2  / 'type'   /  ,
     &           ckey3  / 'indm'   /   , ckey4  / 'isel'   /  ,
     &           ckey5  /  'pl'    /   , ckey6  /  'ss'    /  ,
     &           ckey7  /  'pb'   /    , ckey8  /  'pp'    /  ,
     &           ckey9  /  'sz'   /    , ckey10 / 'ispb'   /  ,
     &           ckey11 / 'ispp'   /

      data  ncncta(1),(icnctva(1,i),i=1,2)   / 2,1,1/
      data  ncncta(2),(icnctva(2,i),i=1,3)   / 3,2,1,1/
      data  ncncta(3),(icnctva(3,i),i=1,4)   / 4,1,2,1,1/
      data  ncncta(4),(icnctva(4,i),i=1,5)   / 5,2,1,2,1,1/
      data  ncncta(5),(icnctva(5,i),i=1,6)   / 6,2,2,1,2,1,1/
      data  ncncta(6),(icnctva(6,i),i=1,7)   / 7,4,2,2,1,2,1,1/
      data  ncncta(7),(icnctva(7,i),i=1,8)   / 8,3,4,2,2,1,2,1,1/
      data  ncncta(8),(icnctva(8,i),i=1,9)   / 9,4,3,4,2,2,1,2,1,1/
      data  ncncta(9),(icnctva(9,i),i=1,10)  /10,2,4,3,4,2,2,1,2,1,1/
      data  ncncta(10),(icnctva(10,i),i=1,11)/11,2,2,4,3,4,2,2,1,2,1,1/
c-----------------------------------------------------------------------
      lbend = .false.
c-----------------------------------------------------------------------

c-----------------------------------------------------------------------
c read in number of data-blocks present in input file.
c-----------------------------------------------------------------------

      read(iunit,1000) c80
      read(c80, *) nbsel

      if(index(c80(1:15),'+').gt.0) then
          lptn_temp=.false.
      elseif(index(c80(1:15),':').gt.0) then
          lptn_temp=.true.
      else
          write(i4unit(-1),2003)'Incorrect element/ion field: ',
     &                          c80(11:15)
          write(i4unit(-1),2004)
          stop
      endif

      ipos1 = index(c80,'/') + 1
      ipos2 = ipos1          + 4
      read(c80(ipos1:ipos2),1001) ionnam

      if (( ionnam(2:2).eq.'+').or.( ionnam(2:2).eq.':') ) then
         esym  = ionnam(1:1) // ' '
      else
         esym  = ionnam(1:2)
      endif

      iz0   = i4eiz0( esym )
      iabt = 0
      is    = i4fctn( ionnam(4:5) , iabt )
      if (iabt.ne.0) is = i4fctn( ionnam(3:4) , iabt )

      is1   = is + 1

      if (nbsel.gt.nstore) then
         write(i4unit(-1),2000) dsname , nstore , nbsel , nstore
         nbsel = nstore
      endif

c-----------------------------------------------------------------------
c input connection vector and partition block if appropriate
c-----------------------------------------------------------------------
      lres=.false.
      ncptn_stack = 0

      if(lptn_temp) then
          ncnct = 0
          read(iunit,'(1a80)') c80
          if(c80(2:10).eq.'---------')then
               read(iunit,'(1a80)')c80
               if(c80(1:2).eq.'//') then
                   lres = .false.
                   backspace(iunit)
                   go to 20
               endif

               lres=.true.
               backspace(iunit)
   10          c80=' '
               read(iunit,'(1a80)')c80
               if(c80(2:10).eq.'---------')go to 20
               nfirst = 1
               iwords = idword
               call xxword( c80 , ' '    , nfirst ,
     &                      iwords  ,
     &                      ifirsta , ilasta , nwords
     &                    )
               do j=1,nwords
                 ncnct = ncnct + 1
                 read(c80(ifirsta(j):ilasta(j)),*)icnctv(ncnct)
               enddo

               go to 10
           else
               write(i4unit(-1),2005)'No connection/partition ',
     &                               'block  present'
               write(i4unit(-1),2006)
               backspace(iunit)
               lptn = .false.
               go to 30
           endif

   20      lresol = .false.
           if(lptn_temp) then
               call  xxrptn( iunit  , ndstack,
     &                       ndptnl , ndptn  , ndptnc ,
     &                       nptnl  , nptn   , nptnc  ,
     &                       iptnla , iptna  , iptnca ,
     &                       lresol , lptn   ,
     &                       c80    ,
     &                       ncptn_stack         , cptn_stack
     &                     )
               lptn=.true.
               iptnl=0
               do j=1,nptnl
                 iptnl=max(iptnl,iptnla(j))
               enddo
           endif

       endif

c-----------------------------------------------------------------------
c input data for each of the data-blocks.  Evaluate largest indm to see
c if confirms unresolved.
c-----------------------------------------------------------------------
   30  max_indm = 0

       do iblk=1,nbsel

c-----------------------------------------------------------------------
c input title, wavelength and other information (check block exists)
c-----------------------------------------------------------------------

         if (.not.lbend) then

            read(iunit,1000)cstrg
            call xxcase(cstrg,c80,'lc')

            if ( c80(1:1).ne.'c') then

               ipos1 =  index(c80,'a') + 1
               ipos2 =  index(c80,'/') - 1

               if (ipos1.eq.1) then
                  ipos1        = 11
                  cwavel(iblk) = c80(1:10)
               elseif (ipos1.gt.10) then
                  cwavel(iblk) = c80(1:10)
               else
                  cwavel(iblk) = c80(1:ipos1-1)
               endif

               call xxslen(cwavel(iblk),ifirst,ilast)
               if((cwavel(iblk)(ilast:ilast).eq.'a').or.
     &             (cwavel(iblk)(ilast:ilast).eq.'A'))then
                    wavel(iblk)=r8fctn(cwavel(iblk)(ifirst:ilast-1),
     &                          iabt)
               else
                   wavel(iblk)=r8fctn(cwavel(iblk)(ifirst:ilast),iabt)
               endif

               read(c80(ipos1:ipos2),*) ida(iblk) , ita(iblk)

               call xxhkey( c80 , ckey2 , cslash , ctype(iblk)  )
               lsup = .false.
               call xxhkey( c80 , ckey1 , cslash , cfile(iblk)  )
               if(cfile(iblk).eq.cblnk8) then
                   ipos1=ipos2+2
                   ipos2=index(c80(ipos1:80),'/')+ipos1-2

                   call xxhkey(c80(ipos1:ipos2),ckey5,colon,c2)
                   iabt  = 0
                   i    = i4fctn( c2 , iabt )
                   if(i.ne.iptnl) then
                      write(i4unit(-1),2003)'partition level mismatch:',
     &                                      'isel = ',iblk
                      write(i4unit(-1),2004)
                      stop
                   endif

                   call xxhkey(c80(ipos1:ipos2),ckey6,colon,c2)
                   iabt  = 0
                   i    = i4fctn( c2 , iabt )
                   if(i.ne.is) then
                      write(i4unit(-1),2003)'superstage mismatch:',
     &                                      'isel = ',iblk
                      write(i4unit(-1),2004)
                      stop
                   else
                      isstgr(iblk)=i+1
                   endif

                   call xxhkey(c80(ipos1:ipos2),ckey9,colon,c2)
                   iabt  = 0
                   i    = i4fctn( c2 , iabt )
                   if(iabt.gt.0) then
                      write(i4unit(-1),2003)'ionis. stage error:',
     &                                      'isel = ',iblk
                      write(i4unit(-1),2004)
                      stop
                   else
                      iszr(iblk)=i
                   endif

                   if(ctype(iblk).eq.'excit')then
                       call xxhkey(c80(ipos1:ipos2),ckey7,colon,c2)
                       iabt  = 0
                       i    = i4fctn( c2 , iabt )
                       if(iabt.gt.0) then
                          write(i4unit(-1),2003)'pb error:',
     &                                      'isel = ',iblk
                          write(i4unit(-1),2004)
                          stop
                       else
                          ispbr(iblk)=i
                          isppr(iblk)=0
                       endif
                   else
                       call xxhkey(c80(ipos1:ipos2),ckey8,colon,c2)
                       iabt  = 0
                       i    = i4fctn( c2 , iabt )
                       if(iabt.gt.0) then
                          write(i4unit(-1),2003)'pp error:',
     &                                      'isel = ',iblk
                          write(i4unit(-1),2004)
                          stop
                       else
                          ispbr(iblk)=0
                          isppr(iblk)=i
                       endif
                   endif

                   lsup = .true.

               endif

               if(.not.lptn_temp)then
                   call xxhkey( c80 , ckey3 , cslash , cindm(iblk)  )
                   iabt=0
                   indm=i4fctn(cindm(iblk),iabt)
                   if(iabt.gt.0) then
                       max_indm=max(max_indm,1)
                   else
                       max_indm=max(max_indm,indm)
                   endif
                   if(ctype(iblk).eq.'excit') then
                       ispbr(iblk)=indm
                       isppr(iblk)=0
                   elseif(ctype(iblk).eq.'recom') then
                       ispbr(iblk)=0
                       isppr(iblk)=indm
                   else
                       ispbr(iblk)=0
                       isppr(iblk)=0
                   endif
                   isstgr(iblk)=is+1
                   iszr(iblk)=is
               elseif(lptn_temp.and.(ctype(iblk).eq.'excit')) then
                   call xxhkey( c80 , ckey10 , cslash , cindm(iblk)  )
               elseif(lptn_temp.and.(ctype(iblk).eq.'recom')) then
                   call xxhkey( c80 , ckey11 , cslash , cindm(iblk)  )
               elseif(lptn_temp.and.(ctype(iblk).eq.'chexc')) then
                   call xxhkey( c80 , ckey11 , cslash , cindm(iblk)  )
               endif
               call xxhkey( c80 , ckey4 , cslash , c3           )
               isela(iblk) = i4fctn( c3 , iabt )

               ndnum = ida(iblk)
               ntnum = ita(iblk)

               if (ntnum.gt.ntdim) then
                  write(i4unit(-1),2001) dsname , iblk  ,
     &                                  'temperatures'  ,
     &                                  ntdim   , ntnum
                  stop
               endif

               if (ndnum.gt.nddim) then
                  write(i4unit(-1),2001) dsname , iblk   ,
     &                                  'densities'      ,
     &                                  nddim   , ndnum
                  stop
               endif

c-----------------------------------------------------------------------
c input temperature, density and photon emissivities for block
c-----------------------------------------------------------------------

               read(iunit,1002) ( teda(itd,iblk) , itd=1,ndnum )
               read(iunit,1002) ( teta(itt,iblk) , itt=1,ntnum )

               do itd=1,ndnum
                  read(iunit,1002) (pec(itt,itd,iblk),
     &                              itt=1,ntnum        )
               enddo

               pmax=0.0d0
               do itt=1,ntnum
                 if(pec(itt,1,iblk).gt.pmax)then
                     pmax=dmax1(pmax,pec(itt,1,iblk))
                 endif
               enddo
                     pec_max(iblk)=pmax

            else

               write(i4unit(-1),2002) dsname  , nbsel    ,
     &                               iblk - 1 , iblk - 1
               lbend = .true.
               nbsel = iblk - 1

            endif

         endif

       enddo

c-----------------------------------------------------------------------
c acquire the comments section as text lines if it exists
c-----------------------------------------------------------------------

       ncmt_stack = 0
       lcmt = .false.

   40  read(iunit,'(1a80)',end=50)cstrg
       call xxcase(cstrg,c80,'lc')
       if ((.not.lcmt).and.(c80(1:10).eq.'c---------').and.
     &     (index(c80,'sccs info').eq.0))then
           lcmt = .true.
           go to 40
       elseif(lcmt.and.(index(c80,'sccs info').eq.0))then
           ncmt_stack=ncmt_stack+1
           cmt_stack(ncmt_stack)=c80
           go to 40
       elseif(index(c80,'sccs info').gt.0)then
           ncmt_stack=ncmt_stack-1
       endif
   50  continue

c-----------------------------------------------------------------------
c     make up connection vectors and root partitions if appropriate
c     in the resolved case with 0 root partition level, the sum over
c     the connection vector gives the number of partitions
c-----------------------------------------------------------------------

      if ((.not.lres).and.(max_indm.eq.1)) then
          ncnct = iz0+1
          do i=1,ncnct
             icnctv(i)=1
          enddo
      elseif ((.not.lres).and.(max_indm.gt.1)) then
          if(iz0.le.iz0_max_res) then
              ncnct=ncncta(iz0)
              do i=1,ncnct
                icnctv(i)=icnctva(iz0,i)
              enddo
          else
              write(i4unit(-1),2003)'Connection vector required',
     &                    'in datasets since iz0 > ',iz0_max_res
              write(i4unit(-1),2004)
              stop
          endif

      endif

      if ((.not.lptn_temp).and.(max_indm.eq.1)) then
          nptnl   = 1
          iptnla(nptnl) = 1
          nptn(1) =  iz0+1
          do i=1,nptn(1)
            iptna(nptnl,i) = i-1
            nptnc(nptnl,i) = 1
            iptnca(1,iptna(nptnl,i)+1,nptnc(nptnl,i))=i-1
          enddo

          call xxmkrp( ndstack       ,
     &                 iz0           , iptnla(nptnl) ,
     &                 ncptn_stack   , cptn_stack
     &                )

       elseif ((.not.lptn_temp).and.(max_indm.gt.1)) then
          nptnl   = 1
          iptnla(nptnl) = 0
          nptn(1)=1
          do i=1,ncnct
            nptn(1)=nptn(1)+icnctv(i)
          enddo
          do i=1,nptn(1)
            iptna(nptnl,i) = i-1
            nptnc(nptnl,i) = 1
            iptnca(1,iptna(nptnl,i)+1,nptnc(nptnl,i))=i-1
          enddo

          call xxmkrp( ndstack       ,
     &                 iz0           , iptnla(nptnl) ,
     &                 ncptn_stack   , cptn_stack
     &                )

      endif

      lptn=lptn_temp

c-----------------------------------------------------------------------
 1000 format(1a80)
 1001 format(a5)
 1002 format(8d9.2)

 2000 format(/1x,31('*'),' xxdata_15 message ',31('*')/
     &        2x,'input phot. emiss. data set name: ',a80/
     &        2x,'number of wavelength data-blocks',
     &           ' in input data set too great.'/
     &        2x,'the maximum number allowed     = ',i3/
     &        2x,'the number present in data set = ',i3/
     &        2x,'therefore only the first ',i2,' have been accepted'/
     &        1x,31('*'),' end of message ',31('*'))
 2001 format(/1x,32('*'),' xxdata_15 error ',32('*')/
     &        2x,'input phot. emiss. data set name: ',a80/
     &        2x,'data-block index: ',i3//
     &        2x,'the number of input electron ',a,' too large'/
     &        2x,'the maximum number allowed       = ',i3/
     &        2x,'the number present in data-block = ',i3/
     &        1x,29('*'),' program terminated ',29('*'))
 2002 format(/1x,31('*'),' xxdata_15 message ',31('*')/
     &        2x,'input ions./photon data set name: ',a80/
     &        2x,'inconsistency in the number of wavelengths',
     &           ' expected and read.'/
     &        2x,'the number expected = ',i3/
     &        2x,'the number read in  = ',i3/
     &        2x,'therefore only ',i3,' have been accepted'/
     &        1x,31('*'),' end of message ',31('*'))
 2003 format(1x,30('*'),' xxdata_15 error   ',30('*')//
     &       2x,a,a,i3,a,i3 )
 2004 format(/1x,30('*'),' program terminates ',29('*'))
 2005 format(1x,30('*'),' xxdata_15 warning ',30('*')//
     &       2x,a,a,i3,a,i3 )
 2006 format(/1x,30('*'),' program continues ',30('*'))
c-----------------------------------------------------------------------

      return
      end

ext: for


text:
      subroutine setprob
      implicit double precision (a-h,o-z)
      character*12 fname
      common /comrp/ umax
      common /comic/ q0
      common /comsrc/ xramp,alf
c
c     # Set the maximum velocity for traffic flow problem
c     # This value is passed to the Riemann solver rp1.f in a common block
c
c     # Set the width of the initial Gaussian pulse
c     # q0 is passed to qinit.f in comic
c
c
      iunit = 7
      fname = 'setprob.data'
c     # open the unit with new routine from Clawpack 4.4 to skip over
c     # comment lines starting with #:
      call opendatafile(iunit, fname)

      read(7,*) umax
      read(7,*) q0
      read(7,*) alf

      xramp = 0.d0

      return
      end

max_issues_repo_name: che-wenchao/D-Claw

max_forks_repo_name: che-wenchao/D-Claw


text:
      SUBROUTINE load_saddle_wsurf (nvariables, xvariables)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE saddle_surface
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: nvariables, mb, nb, ik, j1
      REAL(rprec) :: xvariables(*)
      EXTERNAL unique_boundary, unique_boundary_PG
!-----------------------------------------------

      IF (nopt_wsurf .eq. -1) THEN
         rmn_sad(:numsurf_sad) = xvariables(1:numsurf_sad)
         zmn_sad(:numsurf_sad) = xvariables(numsurf_sad+1:2*numsurf_sad)
         nvariables = 2*numsurf_sad

      ELSE IF (nopt_wsurf .eq. 0) THEN

         rbc = 0;   zbs = 0

         DO ik = 1, irm0_bdy
            rbc(nrz0_opt(ik),0) = xvariables(ik)
         END DO
         DO ik = 1, izm0_bdy
            zbs(nrz0_opt(ik+irm0_bdy),0) = xvariables(ik+irm0_bdy)
         END DO
         DO ik = 1, irho_bdy
            j1 = ik + irm0_bdy + izm0_bdy
            rhobc(nbrho_opt(ik),mbrho_opt(ik)) = xvariables(j1)
         END DO

         nvariables = irm0_bdy + izm0_bdy + irho_bdy

         CALL unique_boundary(rbc, zbs, rhobc, mpol_opt, ntor_opt,
     1                               mpol_opt, ntor_opt, mpol_opt)

!        CONVERT FROM VMEC TO NESCOIL FORM FOR WINDING SURFACE

         rmn_sad = 0
         zmn_sad = 0

         DO ik = 1, numsurf_sad
            mb = m_sad(ik)

            IF (mb .eq. 0) THEN
               nb = n_sad(ik)
               IF (nb .ge. 0) THEN
                  rmn_sad(ik) =  rbc(nb, mb)
                  zmn_sad(ik) = -zbs(nb, mb)
               ELSE
                  nb = -nb
                  rmn_sad(ik) = rbc(nb, mb)
                  zmn_sad(ik) = zbs(nb, mb)
               END IF                              ! mb=0

            ELSE
               nb = -n_sad(ik)
               rmn_sad(ik) = rbc(nb, mb)
               zmn_sad(ik) = zbs(nb, mb)
            END IF
         END DO

      ELSE IF (nopt_wsurf .eq. 1) THEN

         DO ik = 1, irho_bdy
            j1 = ik
            delta_mn(nbrho_opt(ik),mbrho_opt(ik)) = xvariables(j1)
         END DO

         CALL unique_boundary_PG(rbc, zbs, delta_mn, ntor_opt, mpol_opt,
     1                           mpol_opt, ntor_opt)

         nvariables = 0
         DO mb = 0, mpol_opt
            DO nb = -ntor_opt, ntor_opt
               IF( ABS(rbc(nb,mb)) .gt. zero .or.
     1            ABS(zbs(nb,mb)) .gt. zero ) THEN
                  nvariables = nvariables + 1
                  m_sad(nvariables) = mb
                  IF (mb .eq. 0) THEN
                     n_sad(nvariables) = nb
                     rmn_sad(nvariables) = rbc(nb,mb)
                     zmn_sad(nvariables) = -zbs(nb,mb)
                  ELSE
                     n_sad(nvariables) = -nb
                     rmn_sad(nvariables) = rbc(nb,mb)
                     zmn_sad(nvariables) = zbs(nb,mb)
                  END IF
               END IF
            END DO
         END DO

         IF (nvariables .ne. numsurf_sad) THEN
            WRITE(6,*) "nvariables != numsurf_sad in load_saddle_surf"
            STOP
         END IF

         nvariables = irho_bdy

      END IF

      END SUBROUTINE load_saddle_wsurf


text:
! $Id$
! -----------------------------------------------------------
! Module splines
! -----------------------------------------------------------
! Code area 9: general
! -----------------------------------------------------------

!!****h* Conquest/spline_module
!!  NAME
!!
!!  PURPOSE
!!
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   23/05/01
!!  MODIFICATION HISTORY
!!   31/05/2001 dave
!!    Added RCS Id tag to header, increased ROBODoc documentation
!!   20/06/2001 dave
!!    Added RCS Log tag and cq_abort
!!   15:48, 08/04/2003 drb
!!    Bug fixes in splint and dsplint
!!   2019/08/14 16:37 dave
!!    Replacing NR routines
!!***
module splines

  use global_module, only: area_general

  implicit none

contains

! -----------------------------------------------------------
! Subroutine spline
! -----------------------------------------------------------

!!****f* splines/spline *
!!
!!  NAME
!!   spline
!!  USAGE
!!
!!  PURPOSE
!!   Given an array y(1:n) containing a function tabulated at
!!   REGULAR intervals with spacing delta_x, and given values
!!   dy1 and dyn for the first derivative of the function at
!!   the end points, this subroutine returns an array d2y(1:n)
!!   containing the second derivatives of the interpolating
!!   function at the tabulated points. If dy1 and/or dyn are
!!   equal or larger than BIG, the routine is signaled to set
!!   the corresponding boundary condition for a natural spline,
!!   with zero second derivative at that point.
!!
!!   Uses LAPACK dptsv to solve symmetric tridiagonal linear equation
!!  INPUTS
!!   integer :: n - size of table to be splined
!!   real(double) :: delta_x - spacing of values in table
!!   real(double) :: dy1, dyn - end points giving boundaries
!!   real(double), dimension(n) :: y, d2y - table and second derivative
!!  USES
!!   datatypes, numbers
!!  AUTHOR
!!   D. R. Bowler
!!  CREATION DATE
!!   2019/08/13
!!  MODIFICATION HISTORY
!!  SOURCE
  subroutine spline( n, delta_x, y, dy1, dyn, d2y )

    use datatypes
    use numbers
    use GenComms, only: cq_abort
    use memory_module, only: reg_alloc_mem, reg_dealloc_mem, type_dbl

    implicit none

    ! Passed variables
    integer :: n

    real(double) :: delta_x, dy1, dyn
    real(double), dimension(n) :: y, d2y

    ! Local variables
    integer :: i, stat, info
    real(double), dimension(:), allocatable :: b, d, du
    external :: dptsv

    allocate(b(n), d(n), du(n-1),STAT=stat)
    if (stat /= 0) call cq_abort("spline: Error alloc mem: ", n)
    call reg_alloc_mem(area_general, 3*n, type_dbl)

    b = zero
    ! Diagonal (d) and sub-diagonal (du) entries in matrix
    d = four
    du = one

    ! Now set up RHS of linear equation
    if (dy1 > BIG) then ! lower boundary condition set to 'natural'
       b(1) = zero
       b(n) = zero
    else ! or else to have a specified first derivative: 'clamped'
       b(1) = (six/delta_x) * ((y(2) - y(1))/delta_x - dy1 )
       b(n) = (six/delta_x) * (dyn - (y(n) - y(n-1))/delta_x )
       d(1) = two
       d(n) = two
    end if
    do i = 2, n-1
       b(i) = six*(y(i-1) - two*y(i) + y(i+1))/(delta_x * delta_x)
    end do
    ! Solution of A.x = b is returned in b
    call dptsv(n, 1, d, du, b, n, info)
    if(info/=0) call cq_abort("spline: error in dptsv, info is ",info)
    d2y = b
    if(dy1 > BIG) then
       d2y(1) = zero
       d2y(n) = zero
    end if
    deallocate(d,b,du)
    return
  end subroutine spline
!!***

! -----------------------------------------------------------
! Subroutine spline_nonU
! -----------------------------------------------------------

!!****f* splines/spline_nonU *
!!
!!  NAME
!!   spline_nonU - makes a spline table for non-uniform x array
!!  USAGE
!!   spline_nonU(n, x, y, dy1, dyn, d2y)
!!  PURPOSE
!!   Given an array y(1:n) containing a function tabulated at
!!   IRREGULAR intervals given by array x(1:n), and given values
!!   yp1 and ypn for the first derivative of the function at
!!   the end points, this subroutine returns an array d2y(1:n)
!!   containing the second derivatives of the interpolating
!!   function at the tabulated points. If dy1 and/or dyn are
!!   equal or larger than BIG, the routine is signaled to set
!!   the corresponding boundary condition for a natural spline,
!!   with zero second derivative at that point.
!!
!!   Uses LAPACK dgtsv to solve general tridiagonal linear equation
!!  INPUTS
!!
!!
!!  USES
!!
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   2019/08/15
!!  MODIFICATION HISTORY
!!  SOURCE
!!
  subroutine spline_nonU( n, x, y, dy1, dyn, d2y )

    use datatypes
    use numbers
    use GenComms, only: cq_abort
    use memory_module, only: reg_alloc_mem, reg_dealloc_mem, type_dbl

    implicit none

    ! Passed variables
    integer :: n

    real(double) :: dy1, dyn
    real(double), dimension(n) :: x, y, d2y

    ! Local variables
    integer :: i, stat, info
    real(double), dimension(:), allocatable :: b, d, du, dl
    external :: dgtsv

    allocate(b(n), d(n), dl(n-1), du(n-1),STAT=stat)
    if (stat /= 0) call cq_abort("spline: Error alloc mem: ", n)
    call reg_alloc_mem(area_general, 3*n, type_dbl)

    b = zero

    ! Now set up RHS of linear equation
    if (dy1 > BIG) then ! lower boundary condition set to 'natural'
       b(1) = zero
       b(n) = zero
       d(1) = four*(x(2) - x(1))
       d(n) = four*(x(n) - x(n-1))
    else ! or else to have a specified first derivative: 'clamped'
       b(1) = six * ( (y(2) - y(1))/(x(2) - x(1)) - dy1 )
       b(n) = six * ( dyn - (y(n) - y(n-1))/(x(n) - x(n-1)) )
       d(1) = two*(x(2) - x(1))
       d(n) = two*(x(n) - x(n-1))
    end if
    do i = 2, n-1
       dl(i-1) = x(i) - x(i-1)
       d(i)  = two * ( x(i+1) - x(i-1) )
       du(i) = x(i+1) - x(i)
       b(i)  = six*(y(i-1) - y(i))/(x(i) - x(i-1)) + &
            six*(y(i+1) - y(i))/(x(i+1) - x(i))
    end do
    du(1) = x(2) - x(1)
    dl(n-1) = x(n) - x(n-1)
    ! Solution of A.x = b is returned in b
    call dgtsv(n, 1, dl, d, du, b, n, info)
    if(info/=0) call cq_abort("spline: error in dgtsv, info is ",info)
    d2y = b
    if(dy1 > BIG) then
       d2y(1) = zero
       d2y(n) = zero
    end if
    deallocate(d,b,du)
    return
  end subroutine spline_nonU
!!***

end module splines

max_stars_repo_name: negf/CONQUEST-release

max_issues_repo_name: negf/CONQUEST-release

max_forks_repo_name: negf/CONQUEST-release


text:
program helloWorld
	! https://fortran-lang.org/learn/quickstart/hello_world
	print *, 'Hello World!'
end program helloWorld

max_stars_repo_path: Fortran/Hello world/helloWorld.f90

max_issues_repo_path: Fortran/Hello world/helloWorld.f90

max_forks_repo_path: Fortran/Hello world/helloWorld.f90


text:
C$Procedure      SGFREF ( Generic Segments: Fetch references )

      SUBROUTINE SGFREF ( HANDLE, DESCR, FIRST, LAST, VALUES )
      IMPLICIT NONE

C$ Abstract
C
C     Given the descriptor for a generic segment in a DAF file
C     associated with HANDLE, fetch from the references partition
C     of the segment the double precision numbers from FIRST to
C     LAST.
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     DAF Required Reading.
C
C$ Keywords
C
C     GENERIC SEGMENTS
C
C$ Declarations

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR  ( * )
      INTEGER               FIRST
      INTEGER               LAST
      DOUBLE PRECISION      VALUES ( * )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     HANDLE     I   Handle of a DAF open for reading.
C     DESCR      I   Descriptor for a generic segment in the DAF.
C     FIRST      I   The index of the first reference value to fetch.
C     LAST       I   The index of the last reference value to fetch.
C     VALUES     O   The reference values that were requested.
C
C$ Detailed_Input
C
C     HANDLE     is the handle of a DAF file opened for reading
C                that contains the segment described by DESCR.
C
C     DESCR      is the descriptor of the segment with the desired
C                constant values. This must be the descriptor for a
C                segment in the DAF associated with HANDLE.
C
C     FIRST      is the index of the first value to fetch from the
C                reference section of the DAF generic segment associated
C                with HANDLE and DESCR.
C
C     LAST       is the index of the last value to fetch from the
C                constants section of the DAF generic segment associated
C                with HANDLE and DESCR.
C
C$ Detailed_Output
C
C     VALUES      is the array of reference values obtained from the
C                 reference section of the DAF generic segment
C                 associated with HANDLE and DESCR.
C
C$ Parameters
C
C     This subroutine makes use of parameters defined in the file
C     'sgparam.inc'.
C
C$ Files
C
C     See the description of HANDLE above.
C
C$ Exceptions
C
C     1) The error SPICE(REQUESTOUTOFBOUNDS) will be signalled
C        if FIRST is less than 1 or LAST is greater than the
C        number of reference values.
C
C     2) The error SPICE(REQUESTOUTOFORDER) will be signalled
C        if LAST is less than FIRST.
C
C     3) The error SPICE(UNKNOWNREFDIR) will be signalled if the
C        reference directory structure is unrecognized.  The most
C        likely cause of this error is that an upgrade to your
C        version of the SPICE toolkit is needed.
C
C$ Particulars
C
C     This routine allows you to easily fetch values from the reference
C     section of a generic segment.
C
C$ Examples
C
C     Suppose that you have located a DAF generic segment. The code
C     fragment below shows how to fetch the I'th reference value from
C     that segment.
C
C        Declarations:
C
C        DOUBLE PRECISION      REFVAL
C
C        Fetch the Ith reference value from the segment.
C
C        CALL SGFREF ( HANDLE, DESCR, I, I, REFVAL )
C
C
C$ Restrictions
C
C     The segment described by DESCR MUST be a generic segment,
C     otherwise the results of this routine are not predictable.
C
C$ Author_and_Institution
C
C     K.R. Gehringer  (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.2.0, 07-SEP-2001 (EDW)
C
C        Replaced DAFRDA call with DAFGDA.
C
C-    SPICELIB Version 1.0.0, 12-APR-1995 (KRG) (WLT)
C
C-&

C$ Index_Entries
C
C     fetch reference values from a generic segment
C
C-&

C
C     Spicelib Functions
C
      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local Parameters
C
C     Include the mnemonic values for the generic segment declarations.
C
      INCLUDE 'sgparam.inc'

C
C     Local Variables
C
      DOUBLE PRECISION      BUFFER ( 2 )

      INTEGER               B
      INTEGER               BASE
      INTEGER               E
      INTEGER               I
      INTEGER               MYNREF
      INTEGER               MYREFT

      IF ( RETURN() ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'SGFREF' )
C
C     Perform the needed initialization
C
      CALL SGMETA ( HANDLE, DESCR, REFBAS, BASE   )
      CALL SGMETA ( HANDLE, DESCR, RDRTYP, MYREFT )
      CALL SGMETA ( HANDLE, DESCR, NREF,   MYNREF )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'SGFREF' )
         RETURN
      END IF

C
C     Perform checks on the inputs for reasonableness.
C
      IF ( ( FIRST .LT. 1 ) .OR. ( LAST .GT. MYNREF) ) THEN

         CALL SETMSG ( 'The range of reference items requested'
     .   //            ' extends beyond the available range of'
     .   //            ' reference items.  The reference data is'
     .   //            ' available'
     .   //            ' for indexes 1 to #.  You''ve requested'
     .   //            ' data from # to #.'                        )
         CALL ERRINT ( '#', MYNREF                                 )
         CALL ERRINT ( '#', FIRST                                  )
         CALL ERRINT ( '#', LAST                                   )
         CALL SIGERR ( 'SPICE(REQUESTOUTOFBOUNDS)'                 )
         CALL CHKOUT ( 'SGFREF'                                    )
         RETURN

      END IF

      IF ( LAST .LT. FIRST ) THEN

         CALL SETMSG ( 'The last reference item requested, #, is'
     .   //            ' before the first reference item'
     .   //            ' requested, #.'                            )
         CALL ERRINT ( '#', LAST                                   )
         CALL ERRINT ( '#', FIRST                                  )
         CALL SIGERR ( 'SPICE(REQUESTOUTOFORDER)'                  )
         CALL CHKOUT ( 'SGFREF'                                    )
         RETURN

      END IF
C
C     Ok.  We are ready to go. If the reference type is recognized
C     fetch the requested data.
C
      IF ( MYREFT .EQ. IMPLE ) THEN
C
C        The reference values are implied in this case. Read the
C        reference base value and step. If we fail, check out and
C        return; we don't want to try and comput anything with bogus
C        data.
C
         B = BASE + 1
         E = BASE + 2

         CALL DAFGDA ( HANDLE, B, E, BUFFER )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'SGFREF' )
            RETURN
         END IF
C
C        Now simply compute the reference values using the implicit
C        model for them.
C
         DO I = FIRST, LAST

            VALUES(I) = BUFFER(1) + DINT ( DBLE(I-1) * BUFFER(2) )

         END DO

      ELSE IF ( MYREFT .EQ. IMPCLS ) THEN
C
C        The reference values are implied in this case. Read the
C        reference base value and step. If we fail, check out and
C        return; we don't want to try and comput anything with bogus
C        data.
C
         B = BASE + 1
         E = BASE + 2

         CALL DAFGDA ( HANDLE, B, E, BUFFER )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'SGFREF' )
            RETURN
         END IF
C
C        Now simply compute the reference values using the implicit
C        model for them.
C
         DO I = FIRST, LAST

            VALUES(I) = BUFFER(1) + DINT ( DBLE(I-1) * BUFFER(2) )

         END DO

      ELSE IF (      MYREFT .EQ. EXPLE
     .          .OR. MYREFT .EQ. EXPLT
     .          .OR. MYREFT .EQ. EXPCLS ) THEN
C
C        In this case the reference values are actually stored
C        in the file.  This is even easier than the last case.
C        We simply fetch them with a call to DAF. We do not check for a
C        failure here, since all we do after the attempt to read is
C        checkout and return anyway.
C
         B = BASE + FIRST
         E = BASE + LAST

         CALL DAFGDA ( HANDLE, B, E, VALUES )

      ELSE

         CALL SETMSG ( 'The generic DAF segment you attempted'
     .   //            ' to read has an unsupported reference'
     .   //            ' directory structure. The integer code'
     .   //            ' given for this structure is #. The'
     .   //            ' likely cause of this anomoly is that'
     .   //            ' your version of SPICELIB needs to be'
     .   //            ' updated. Contact your system'
     .   //            ' administrator or NAIF for a toolkit'
     .   //            ' update. '                                 )
         CALL ERRINT ( '#', MYREFT                                 )
         CALL SIGERR ( 'SPICE(UNKNOWNREFDIR)'                      )
         CALL CHKOUT ( 'SGFREF'                                    )
         RETURN

      END IF

      CALL CHKOUT ( 'SGFREF' )
      RETURN

      END


module util_mod
  use working_prec_mod, only: ik, rk
  implicit none
  private

  public :: det
  public :: inverse
  public :: trace
  public :: math_cross_product
  public :: math_euclidean_norm
contains

  ! det: returns determinant of 3x3 matrix (sarrus)
  pure real(rk) function det (matrix)
    real(rk), dimension(3,3), intent(in) :: matrix
    det  = matrix(1,1)*matrix(2,2)*matrix(3,3) &
      + matrix(1,2)*matrix(2,3)*matrix(3,1) &
      + matrix(1,3)*matrix(2,1)*matrix(3,2) &
      - matrix(1,3)*matrix(2,2)*matrix(3,1) &
      - matrix(1,1)*matrix(2,3)*matrix(3,2) &
      - matrix(1,2)*matrix(2,1)*matrix(3,3)
  end function det

  pure function inverse(matrix) result (invbox)
    real(rk), intent(in) :: matrix(3,3)
    real(rk)             :: invbox(3,3)
    real(rk)             :: adj(3,3) ! adjunkt

    adj(1,1) = matrix(2,2)*matrix(3,3) - matrix(2,3)*matrix(3,2)
    adj(2,1) = matrix(3,1)*matrix(2,3) - matrix(3,3)*matrix(2,1)
    adj(3,1) = matrix(2,1)*matrix(3,2) - matrix(2,2)*matrix(3,1)
    adj(1,2) = matrix(3,2)*matrix(1,3) - matrix(3,3)*matrix(1,2)
    adj(2,2) = matrix(1,1)*matrix(3,3) - matrix(1,3)*matrix(3,1)
    adj(3,2) = matrix(3,1)*matrix(1,2) - matrix(3,2)*matrix(1,1)
    adj(1,3) = matrix(1,2)*matrix(2,3) - matrix(1,3)*matrix(2,2)
    adj(2,3) = matrix(2,1)*matrix(1,3) - matrix(2,3)*matrix(1,1)
    adj(3,3) = matrix(1,1)*matrix(2,2) - matrix(1,2)*matrix(2,1)

    invbox = 1._rk/det(matrix) * adj
  end function inverse

  pure real(rk) function trace (matrix)
    real(rk), intent(in) :: matrix(3,3)

    trace = ( matrix(1,1) + matrix(2,2) + matrix(3,3) )
  end function trace

  pure function math_cross_product (a, b) result (res)
    real(rk), dimension(3), intent(in) :: a, b
    real(rk), dimension(3) :: res

    res(1) = a(2) * b(3) - a(3) * b(2)
    res(2) = a(3) * b(1) - a(1) * b(3)
    res(3) = a(1) * b(2) - a(2) * b(1)
  end function math_cross_product

  pure function math_euclidean_norm (a) result (a_n)
    real(rk), dimension(:), intent(in) :: a
    real(rk)                           :: a_n

    a_n = sqrt (sum (a**2))
  end function math_euclidean_norm

end module util_mod


text:
module object_interface
  implicit none

  type, abstract :: object
  contains
    procedure(write_formatted_interface), deferred :: write_formatted
    generic :: write(formatted) => write_formatted
  end type

  abstract interface
    subroutine write_formatted_interface(this, unit, iotype, vlist, iostat, iomsg)
      import object
      implicit none
      class(object), intent(in) :: this
      integer, intent(in) :: unit, vlist(:)
      character(len=*), intent(in) :: iotype
      integer, intent(out) :: iostat
      character(len=*), intent(inout) :: iomsg
    end subroutine
  end interface

  type, abstract, extends(object) :: oracle
  contains
    procedure(negative_interface), deferred :: negative
    generic :: operator(-) => negative
  end type

  abstract interface
    function negative_interface(this)
      import oracle
      implicit none
      class(oracle), intent(in) :: this
      class(oracle), allocatable :: negative_interface
    end function
  end interface

  type, extends(oracle) :: results_t
    integer :: i=1
  contains
    procedure write_formatted
    procedure negative
  end type

contains

    subroutine write_formatted(this, unit, iotype, vlist, iostat, iomsg)
      implicit none
      class(results_t), intent(in) :: this
      integer, intent(in) :: unit, vlist(:)
      character(len=*), intent(in) :: iotype
      integer, intent(out) :: iostat
      character(len=*), intent(inout) :: iomsg
      print *, this%i
      iostat = 0
    end subroutine

    function negative(this)
      implicit none
      class(results_t), intent(in) :: this
      class(oracle), allocatable :: negative
      type(results_t) negative_this
      negative_this%i = - this%i
      negative = negative_this
    end function

end module

  use object_interface
  write(*,*) -results_t()
end

max_stars_repo_name: rouson/bug-reports

max_issues_repo_name: rouson/bug-reports

max_forks_repo_name: rouson/bug-reports


text:
program decl_alloca
  integer,save ::i = 10
  if (i == 9) then
   i = 1; i = 2
  elseif (i == 10) then
  i= 3;
  i = 4
  end if

  print *,i

end program decl_alloca

max_stars_repo_name: clementval/fc

max_issues_repo_name: clementval/fc

max_forks_repo_name: clementval/fc