text:
program test_variable_dict

    use variable_dict_interface,    only : var_dict_t
    use variable_interface,         only : variable_t
    use grid_interface,             only : grid_t

    implicit none

    type(var_dict_t)    :: var_collection
    type(variable_t)    :: var1, var2, var3, output_var
    type(grid_t)        :: grid
    logical :: passed = .True.

    ! define a grid for a test variable
    call grid%set_grid_dimensions(nx=10,ny=10,nz=5)
    ! initialize a test variable with that grid
    call var1%initialize(grid)

    call grid%set_grid_dimensions(nx=2,ny=15,nz=5)
    ! initialize a test variable with that grid
    call var2%initialize(grid)

    ! initialize a test variable with a shape spec instead of a grid spec
    call var3%initialize( [2,5] )

    ! add the test variable to the dictionary for the key "data"
    call var_collection%add_var("data_first",var1)
    call var_collection%add_var("data",var2)
    call var_collection%add_var("data_third",var3)

    output_var = var_collection%get_var("data")

    if (.not.(output_var%three_d .eqv. var2%three_d))          passed = .False.
    if (.not.(output_var%n_dimensions == var2%n_dimensions))   passed = .False.
    if (.not.all(output_var%dim_len == var2%dim_len))          passed = .False.

    if (passed) then
        print*, "test_variable_dict Passed"
    else
        print*, "test_variable_dict Failed"
    endif
end program

max_stars_repo_name: scrasmussen/icar

max_issues_repo_name: scrasmussen/icar

max_forks_repo_name: scrasmussen/icar


text:
C$Procedure HRMESP ( Hermite polynomial interpolation, equal spacing  )

      SUBROUTINE HRMESP ( N,  FIRST,  STEP,  YVALS,  X,  WORK,  F,  DF )
      IMPLICIT NONE

C$ Abstract
C
C     Evaluate, at a specified point, an Hermite interpolating
C     polynomial for a specified set of coordinate pairs whose
C     abscissas are equally spaced.
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     INTERPOLATION
C     POLYNOMIAL
C
C$ Declarations

      INTEGER               N
      DOUBLE PRECISION      FIRST
      DOUBLE PRECISION      STEP
      DOUBLE PRECISION      YVALS ( 2*N )
      DOUBLE PRECISION      X
      DOUBLE PRECISION      WORK  ( 2*N, 2 )
      DOUBLE PRECISION      F
      DOUBLE PRECISION      DF

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     N          I   Number of points defining the polynomial.
C     FIRST      I   First abscissa value.
C     STEP       I   Step size.
C     YVALS      I   Ordinate and derivative values.
C     X          I   Point at which to interpolate the polynomial.
C     WORK      I-O  Work space array.
C     F          O   Interpolated function value at X.
C     DF         O   Interpolated function's derivative at X.
C
C$ Detailed_Input
C
C     N              is the number of points defining the polynomial.
C                    The array YVALS contains 2*N elements.
C
C     FIRST,
C     STEP           are, respectively, a starting abscissa value and a
C                    step size that define the set of abscissa values
C
C                       FIRST   +   (I-1) * STEP,     I = 1, ..., N
C
C                    STEP must be non-zero.
C
C
C     YVALS          is an array of length 2*N containing ordinate and
C                    derivative values for each point in the domain
C                    defined by FIRST, STEP, and N.  The elements
C
C                       YVALS( 2*I - 1 )
C                       YVALS( 2*I     )
C
C                    give the value and first derivative of the output
C                    polynomial at the abscissa value
C
C                       FIRST   +   I * STEP
C
C                    where I ranges from 1 to N.
C
C
C     WORK           is a work space array.  It is used by this routine
C                    as a scratch area to hold intermediate results.
C
C
C     X              is the abscissa value at which the interpolating
C                    polynomial and its derivative are to be evaluated.
C
C$ Detailed_Output
C
C     F,
C     DF             are the value and derivative at X of the unique
C                    polynomial of degree 2N-1 that fits the points and
C                    derivatives defined by FIRST, STEP, and YVALS.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If STEP is zero, the error SPICE(INVALIDSTEPSIZE) will be
C         signaled.
C
C     2)  If N is less than 1, the error SPICE(INVALIDSIZE) is
C         signaled.
C
C     3)  This routine does not attempt to ward off or diagnose
C         arithmetic overflows.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Users of this routine must choose the number of points to use
C     in their interpolation method.  The authors of Reference [1] have
C     this to say on the topic:
C
C        Unless there is solid evidence that the interpolating function
C        is close in form to the true function f, it is a good idea to
C        be cautious about high-order interpolation.  We
C        enthusiastically endorse interpolations with 3 or 4 points, we
C        are perhaps tolerant of 5 or 6; but we rarely go higher than
C        that unless there is quite rigorous monitoring of estimated
C        errors.
C
C     The same authors offer this warning on the use of the
C     interpolating function for extrapolation:
C
C        ...the dangers of extrapolation cannot be overemphasized:
C        An interpolating function, which is perforce an extrapolating
C        function, will typically go berserk when the argument x is
C        outside the range of tabulated values by more than the typical
C        spacing of tabulated points.
C
C$ Examples
C
C
C     1)  Fit a 7th degree polynomial through the points ( x, y, y' )
C
C             ( -1,      6,       3 )
C             (  1,      8,      11 )
C             (  3,   2210,    5115 )
C             (  5,  78180,  109395 )
C
C         and evaluate this polynomial at x = 2.
C
C
C            PROGRAM TEST_HRMINT
C
C            DOUBLE PRECISION      ANSWER
C            DOUBLE PRECISION      DERIV
C            DOUBLE PRECISION      FIRST
C            DOUBLE PRECISION      STEP
C            DOUBLE PRECISION      YVALS (8)
C            DOUBLE PRECISION      WORK  (8,2)
C            INTEGER               N
C
C
C            N         =       4
C
C            YVALS(1)  =       6.D0
C            YVALS(2)  =       3.D0
C            YVALS(3)  =       8.D0
C            YVALS(4)  =      11.D0
C            YVALS(5)  =    2210.D0
C            YVALS(6)  =    5115.D0
C            YVALS(7)  =   78180.D0
C            YVALS(8)  =  109395.D0
C
C            FIRST     =  -1.D0
C            STEP      =   2.D0
C
C            CALL HRMESP ( N,    FIRST, STEP,   YVALS,
C           .              2.D0, WORK,  ANSWER, DERIV )
C
C            WRITE (*,*) 'ANSWER = ', ANSWER
C            WRITE (*,*) 'DERIV  = ', DERIV
C            END
C
C
C        The returned value of ANSWER should be 141.D0, and the returned
C        derivative value should be 456.D0, since the unique 7th degree
C        polynomial that fits these constraints is
C
C                     7       2
C           f(x)  =  x   +  2x  + 5
C
C$ Restrictions
C
C     None.
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           William T. Vetterling (see sections 3.0 and 3.1).
C
C     [2]  "Elementary Numerical Analysis---An Algorithmic Approach"
C           by S. D. Conte and Carl de Boor.  See p. 64.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.1, 28-JAN-2014 (NJB)
C
C        Fixed a few comment typos.
C
C-    SPICELIB Version 1.2.0, 31-JAN-2002 (EDW)
C
C        Added the use of DBLE to convert integer values
C        used in DOUBLE PRECISION calculations.
C
C-    SPICELIB Version 1.1.0, 28-DEC-2001 (NJB)
C
C        Blanks following final newline were truncated to
C        suppress compilation warnings on the SGI-N32 platform.
C
C-    SPICELIB Version 1.0.0, 01-MAR-2000 (NJB)
C
C-&

C$ Index_Entries
C
C     interpolate function using Hermite polynomial
C     Hermite interpolation
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      C1
      DOUBLE PRECISION      C2
      DOUBLE PRECISION      DENOM
      DOUBLE PRECISION      NEWX
      DOUBLE PRECISION      TEMP
      DOUBLE PRECISION      XI
      DOUBLE PRECISION      XIJ

      INTEGER               I
      INTEGER               J
      INTEGER               NEXT
      INTEGER               PREV
      INTEGER               THIS

C
C     Check in only if an error is detected.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     No data, no interpolation.
C
      IF ( N .LT. 1 ) THEN

         CALL CHKIN  ( 'HRMESP'                              )
         CALL SETMSG ( 'Array size must be positive; was #.' )
         CALL ERRINT ( '#',  N                               )
         CALL SIGERR ( 'SPICE(INVALIDSIZE)'                  )
         CALL CHKOUT ( 'HRMESP'                              )
         RETURN

      END IF

C
C     The step size must be non-zero.
C
      IF ( STEP .EQ. 0.D0 ) THEN

         CALL CHKIN  ( 'HRMESP'                 )
         CALL SETMSG ( 'Step size was zero.'    )
         CALL SIGERR ( 'SPICE(INVALIDSTEPSIZE)' )
         CALL CHKOUT ( 'HRMESP'                 )
         RETURN

      END IF

C
C     We can simplify the interpolation problem by shifting
C     and scaling the abscissa values so that they start at 1
C     and are separated by a unit step. All we need to do here is
C     shift and scale X.
C
      NEWX  =  (  ( X - FIRST ) / STEP  )  +  1.D0

C
C     For consistency with our scaled horizontal axis, we'll have
C     scale our local derivative values by STEP, and scale our final
C     computed derivative by 1/STEP.
C
C     Copy the input array into WORK.  Scale the derivatives at this
C     step. After this, the first column of WORK represents the first
C     column of our triangular interpolation table.
C
      DO I = 1, 2*N-1, 2
         WORK(I,1) = YVALS(I)
      END DO

      DO I = 2, 2*N, 2
         WORK(I,1) = YVALS(I) * STEP
      END DO

C
C     Compute the second column of the interpolation table: this
C     consists of the N-1 values obtained by evaluating the
C     first-degree interpolants at NEWX. We'll also evaluate the
C     derivatives of these interpolants at NEWX and save the results in
C     the second column of WORK. Because the derivative computations
C     depend on the function computations from the previous column in
C     the interpolation table, and because the function interpolation
C     overwrites the previous column of interpolated function values,
C     we must evaluate the derivatives first.
C

      DO I = 1, N-1

         C1     = DBLE( (I+1) )  - NEWX
         C2     =  NEWX  - DBLE(I)

C
C        The second column of WORK contains interpolated derivative
C        values.
C
C        The odd-indexed interpolated derivatives are simply the input
C        derivatives, after scaling.
C
         PREV = 2*I  - 1
         THIS = PREV + 1
         NEXT = THIS + 1

         WORK( PREV,  2 )  =    WORK( THIS, 1 )

C
C        The even-indexed interpolated derivatives are the slopes of
C        the linear interpolating polynomials for adjacent input
C        abscissa/ordinate pairs. No scaling is needed here.
C
         WORK( THIS, 2 ) = ( WORK(NEXT, 1) - WORK(PREV, 1) )

C
C        The first column of WORK contains interpolated function values.
C        The odd-indexed entries are the linear Taylor polynomials,
C        each input abscissa value, evaluated at NEWX.
C
         TEMP  = WORK(THIS, 1) * ( NEWX - DBLE(I) )  +  WORK(PREV, 1)

         WORK( THIS, 1 ) = (   C1 * WORK( PREV, 1 )
     .                       + C2 * WORK( NEXT, 1 )  )

         WORK( PREV, 1 ) = TEMP

      END DO

C
C     The last column entries were not computed by the preceding loop;
C     compute them now.
C
      WORK ( 2*N - 1,  2 )  =    WORK( 2*N,     1 )
      WORK ( 2*N - 1,  1 )  =    WORK( 2*N,     1 ) * ( NEWX - N )
     .                         + WORK( 2*N - 1, 1 )

C
C     Compute columns 3 through 2*N of the table.
C
      DO J = 2, 2*N-1

         DO I = 1, 2*N-J
C
C           In the theoretical construction of the interpolation table,
C           there are 2*N abscissa values, since each input abcissa
C           value occurs with multiplicity two. In this theoretical
C           construction, the Jth column of the interpolation table
C           contains results of evaluating interpolants that span J+1
C           consecutive abscissa values. The indices XI and XIJ below
C           are used to pick the correct abscissa values out of this
C           sequence of 2*N values.
C
            XI       =   DBLE( ( I     + 1 ) / 2 )
            XIJ      =   DBLE( ( I + J + 1 ) / 2 )

            C1       =     XIJ   -  NEWX
            C2       =     NEWX  -  XI

            DENOM    =     XIJ   -  XI

C
C           Compute the interpolated derivative at NEWX for the Ith
C           interpolant. This is the derivative with respect to NEWX of
C           the expression for the interpolated function value, which is
C           the second expression below. This derivative computation
C           is done first because it relies on the interpolated function
C           values from the previous column of the interpolation table.
C
C           The derivative expression here corresponds to equation
C           2.35 on page 64 in reference [2].
C
            WORK(I,2) = (              C1  * WORK(I,   2)
     .                    +            C2  * WORK(I+1, 2)
     .                    + ( WORK(I+1, 1) - WORK(I,   1) )  )  / DENOM
C
C           Compute the interpolated function value at NEWX for the Ith
C           interpolant.
C
            WORK(I,1) = ( C1 * WORK(I,1)  +  C2 * WORK(I+1,1) ) / DENOM

         END DO

      END DO

C
C     Our interpolated function value is sitting in WORK(1,1) at this
C     point.  The interpolated derivative is located in WORK(1,2).
C     We must undo the scaling of the derivative. We've already
C     checked that STEP is non-zero.
C
      F   =  WORK( 1, 1 )
      DF  =  WORK( 1, 2 )  /  STEP

      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


! -----------------------------------------------------------------------------
!
! Copyright (c) 2009 - 2012 Chris Martin, Kasia Boronska, Jenny Young,
! Peter Jimack, Mike Pilling
!
! Copyright (c) 2017 Sam Cox, Roberto Sommariva
!
! This file is part of the AtChem2 software package.
!
! This file is covered by the MIT license which can be found in the file
! LICENSE.md at the top level of the AtChem2 distribution.
!
! -----------------------------------------------------------------------------

! ******************************************************************** !
! ATCHEM2 -- MODULE configFunctions
!
! This module contains helper functions that query lists in various ways
! in order to extract the required species etc based on some criterion.
! ******************************************************************** !
module config_functions_mod
  implicit none

contains

  ! -----------------------------------------------------------------
  ! This takes in masterSpeciesList, and checks whether each member of
  ! testspeciesList is in masterSpeciesList. When it finds a match, it
  ! adds the number of the line in masterSpeciesList to returnArray in
  ! the next available space, thus each element of returnArray
  ! corresponds to the same element in testSpeciesList. If not found,
  ! then abort.
  subroutine matchNameToNumber( masterSpeciesList, testSpeciesList, returnArray )
    use, intrinsic :: iso_fortran_env, only : stderr => error_unit
    use types_mod
    use storage_mod, only : maxSpecLength

    character(len=maxSpecLength), contiguous, intent(in) :: masterSpeciesList(:), testSpeciesList(:)
    integer(kind=NPI), intent(out) :: returnArray(:)
    integer(kind=NPI) :: counter, i

    ! loop over each element of testSpeciesList. If a match is made,
    ! then append to returnArray the number of the species from
    ! testSpeciesList within the masterSpeciesList. Otherwise, abort.
    counter = 0
    do i = 1, size( testSpeciesList )
      counter = counter + 1
      if ( counter > size( returnArray ) ) then
        write (stderr,*) 'matchNameToNumber(): counter > size( returnArray ).'
        stop
      end if
      returnArray(counter) = getIndexWithinList(masterSpeciesList, testSpeciesList(i))
      if ( returnArray(counter) == 0 ) then
        write (stderr,*) 'matchNameToNumber(): ' // testSpeciesList(i) // ' not found in list.'
        stop
      end if
    end do

    return
  end subroutine matchNameToNumber

  ! -----------------------------------------------------------------
  ! Search masterList for target, and return the index id. If not
  ! found, return 0.
  pure function getIndexWithinList( masterList, target ) result ( id )
    use types_mod

    character(len=*), contiguous, intent(in) :: masterList(:)
    character(len=*), intent(in) :: target
    integer(kind=NPI) :: j, id

    id = 0
    do j = 1, size( masterList )
      if ( masterList(j) == target ) then
        id = j
        return
      end if
    end do

  end function getIndexWithinList

  ! ----------------------------------------------------------------- !
  ! At the end of this function, each row of r is associated to one of
  ! the species in rSpecies. Each element of the row corresponds to a
  ! reaction in which this species appears as a product or reactant.
  ! Each element consists of %reaction holding the reaction number, and
  ! %frequency holding the number of occurences of that species in that
  ! reaction.
  ! chs contains the product or reactant information.
  ! arrayLen is used to keep track of how many are present in each row.
  subroutine findReactionsWithProductOrReactant( rSpecies, chs, r, arrayLen )
    use types_mod

    integer(kind=NPI), intent(in) :: rSpecies(:), chs(:,:)
    type(reaction_frequency_pair), intent(inout) :: r(:,:)
    integer(kind=NPI), intent(out) :: arrayLen(:)
    integer(kind=NPI) :: rCounter, i, j

    ! For each interesting species, held in rSpecies, find all reactions
    ! in chs which match (i.e. second column of chs matches first element of
    ! given row from r), and append the number of that reaction (first column
    ! of chs) to this row of r. arrayLen keeps track of how long each row in r is.
    if ( size( arrayLen ) /= size( r, 1 ) ) then
      stop "size(arrayLen) /= size(r, 1) in findReactionsWithProductOrReactant()."
    end if
    ! initialise counter for r array
    rCounter = 0_NPI
    ! loop over interesting species (i.e. over 1st index of r)
    do i = 1, size( arrayLen )
      ! loop over elements of 2nd index of chs
      do j = 1, size( chs, 2 )
        ! Is the second element of this row in chs (a species number)
        ! equal to the same element in rSpecies?  If so, then append the first
        ! element of this row in chs (the equation number) to this row
        ! in r, and update the length counter arrayLen for this row.
        if ( chs(2, j) == rSpecies(i) ) then
          ! Match found
          ! If the reaction number is not the same as previously, then move on in the array
          ! Regardless of that, fill r with the reaction number
          ! Handle the corner case

          if ( rCounter == 0_NPI ) then
            rCounter = 1_NPI
          elseif ( chs(1, j) /= r(i, rCounter)%reaction ) then
            rCounter = rCounter + 1_NPI
          end if
          r(i, rCounter)%reaction = chs(1, j)
          r(i, rCounter)%frequency = r(i, rCounter)%frequency + 1_NPI
        end if
      end do
      arrayLen(i) = rCounter
      rCounter = 0_NPI
    end do

    return
  end subroutine findReactionsWithProductOrReactant

  ! -----------------------------------------------------------------
  ! This function outputs interestSpeciesConcList, the concentration
  ! of each species of interest, in the same order as the species are
  ! in subsetOfSpecies
  pure function getSubsetOfConcs( masterConcList, subsetOfSpecies ) result ( interestSpeciesConcList )
    use types_mod
    use species_mod, only : getSpeciesList
    use storage_mod, only : maxSpecLength

    real(kind=DP), intent(in) :: masterConcList(:)
    character(len=maxSpecLength), intent(in) :: subsetOfSpecies(:)
    character(len=maxSpecLength), allocatable :: allSpecies(:)
    real(kind=DP) :: interestSpeciesConcList(size( subsetOfSpecies ))
    integer(kind=NPI) :: i, j

    ! Set interestSpeciesConcList(j) to the value of the concentration
    ! pulled from masterConcList, using the elements of specInt as key
    allSpecies = getSpeciesList()
    do i = 1, size( allSpecies )
      do j = 1, size( subsetOfSpecies )
        if ( trim( subsetOfSpecies(j) ) == trim( allSpecies(i) ) ) then
          interestSpeciesConcList(j) = masterConcList(i)
          exit
        end if
      end do
    end do

    return
  end function getSubsetOfConcs

end module config_functions_mod


text:
      program patint
c
c **********************************************************************
c *            Convert Patran6 hardcopy file to Interleaf ASCII file   *
c *                                                                    *
c *                   By: M. Keppel 2/27/91  - patran5 version         *
c *                       B. Dodds  12/1/91  - added color support &   *
c *                                            formats for ileaf5      *
c *                       M. Keppel 12/16/91 - fixed bug for closing   *
c *                                            last polygon of row &   *
c *                                            models with hoels       *
c *                       R. Dodds   2/14/92 - fixes problems with     *
c *                                            text lines              *
c *                       R. Dodds   1/4/95  - fixes problems found in *
c *                                            port to IBM RISC 6000   *
c *                                                                    *
c *                  ------------- conversion to patran6 ------------  *
c *                                                                    *
c *                       A. Gullerud 7/9/96 - updated to use new      *
c *                                            patran6 hexadecimal     *
c *                                            format                  *
c *                       A. Gullerud 10/29/96 - updated to use patran6*
c *                                            polygon fills instead of*
c *                                            scanlines, use v7 for   *
c *                                            lines instead of v6, and*
c *                                            fixed color             *
c *                       A. Gullerud 2/3/97 - add .doc to end of file *
c *                                            name (ileaf6 needs it). *
c *                                            also remove all refs.   *
c *                                            to TPS-4 (ileaf4).      *
c *                                                                    *
c **********************************************************************
c *                                                                    *
c *     Procedure for Handling Scan Line Data                          *
c *                                                                    *
c *     Patran handles fringe plots in several ways.  In Patran 5,     *
c *     fringe plots are either output as a series of polygons and     *
c *     lines plotted from the point farthest from the viewer to       *
c *     the front (preferred), or as a series of thin rectangles which *
c *     sweep across the picture, defining a bitmap-like picture.      *
c *     These methods do not require the use of scanlines, which is    *
c *     the method used by Patran 2.5  However, the code for handling  *
c *     scanlines remains within this program in case it is needed in  *
c *     the future.                                                    *
c *                                                                    *
c *     Scan lines are translated into polygons in the following manner.
c *     Each scan line is pixinc pixels in height (pixinc is given in  *
c *     a type record 7). The polygon is started at the y coordinate   *
c *     y + pixinc / 2 (The top of the scan line) and extended straight*
c *     down to y (The middle of the scan line).  The polygon then     *
c *     connects to the middle of the next scan line and continues to  *
c *     connect to the middle of the next scan line until the number of*
c *     colors in the scan line changes.  When this occurs the polygon *
c *     is closed by extending straight down from y (The middle of the *
c *     scan line) to y - pixinc / 2 (The bottom of the scan line).    *
c *     The closed polygons are written to the file and new polygons   *
c *     are started.  The points in the polygon are stored in a linked *
c *                                                                    *
c *     Note: modifications for multiple, consecutive scan lines with  *
c *           with same Y coordinate have been added.                  *
c *                                                                    *
c **********************************************************************
c
      character*256 fname, string, string2, homed, timest*8, line,
     &     linetmp, dirname
      integer iin, iout, infil, outfil, intl_version, trgevn, str_len,
     &     num_char, str_len_tmp
      integer inrec(50000)
      integer head(200), tail(200), space(5000), ghead
      integer ncolor(200), ocolor(200), npoly, opoly, tot_len
      logical dopoly, tilde, ferr
      real x(5000), y(5000), xl(201)
      logical first, error
      real xy(4), xy1(2), xy2(2), xyc(2)
      real magenta
      common /device/ xr, yr, ratior, pixinc, devx, devy
      integer counter
c
c                 Initialize
c
      iin    = 5
      iout   = 6
      infil  = 20
      outfil = 21
      devx   = 11.0
      devy   = 8.5
      first  = .true.
      opoly  = 0
      maxlen2 = 256
      counter = 1
c
c                 Initialize garbage list
c
      do i = 1, 5000
          space(i) = i+1
      end do
      space(5000) = 0
      ghead = 1
c
c                 Print out header.
c
      write(iout,9100)
c
c                 Get Patran hardcopy file name. Open for input.
c
      ferr = .false.
 10   continue
      if (ferr) then
         write (iout,'(/," >> ERROR: file cannot be opened:",a,/)')
     &      fname
      endif
      ferr = .true.
      write(iout,9000)
     &  ' >> Patran Hardcopy File (default file is patran.hrd.01): '
      fname(1:) = ' '
      read(iin,9010) fname
      call stripf( fname, str_len, error )
      if ( error ) fname(1:) = 'patran.hrd.01'
      open(infil, file=fname, status='old', iostat=ierr )
      if ( ierr .ne. 0 ) then
          write(iout,*) '    >  Invalid Selection, Try Again...'
          go to 10
      end if
      write(iout,*) '>> Patran Hardcopy File Opened Ok'
c
c                 Get Version of Interleaf for Document Generation
c                 1) Ileaf 5.2 (B&W) or 2) Ileaf 5.2 (Color)
c
      write(iout,*) '>> Interleaf Document Type:'
      write(iout,*) '      1 -- Ileaf 5 or 6 (Black & White) <- default'
      write(iout,*) '      2 -- Ileaf 5 or 6 (Color)'
      write(iout,9000) ' >> Selection: '
      read(iin,*) intl_version
      if ( intl_version .le. 0 .or. intl_version .gt. 2 )
     &                                   intl_version = 1
c
c                  Get name of directory to store the interleaf file
c
 20   continue
      tilde = .false.
      write(iout,9000)
     &  ' >> Directory for Ileaf file (default is ~/desktop5.0/ ): '
      dirname(1:) = ' '
      read(iin,9010) dirname
      call stripf( dirname, str_len, error )
      if ( error ) then
         dirname(1:) = '~/desktop5.0/'
         str_len = 13
      endif
c
c                       if no slash at end of name, put in a slash
c
      if (dirname(str_len:str_len).ne.'/') then
	 dirname(str_len+1:str_len+1) = '/'
	 str_len = str_len + 1
      endif
c
c                       if ~ is specified, resolve home directory
c
      if (dirname(1:1) .eq.'~') then
	 tilde = .true.
         nchome = trgevn( 'HOME'//char(0), homed(1:) )
         if ( nchome .eq. 0 )  then
            write(iout,9022)
            stop
         end if
      endif
c
c                 Form filename Patran_xx.xx.xx.doc where xx.xx.xx is the
c                 current time.  Open file for output on desktop.
c
      call time( timest )
      timest(3:3) = '.'
      timest(6:6) = '.'
      string(1:) = ' '
      write(string(1:),9020) timest(1:8)
      if (tilde) then
         fname(1:) = homed(1:nchome) // dirname(2:str_len) //
     &         string(1:15) // ".doc"
         tot_len = nchome + (str_len - 1) + 15 + 4
      else
         fname(1:) = dirname(1:str_len) // string(1:15) // ".doc"
         tot_len = str_len + 15 + 4
      endif
      open(outfil, file=fname, status='new',
     &     recl=maxlen2, err=10,
     &     access='sequential', form='formatted', iostat=ierr)
      write(iout,9140) fname(1:tot_len)
c
c                 Initialize output file (Page & Color Definitions).
c                 Note: Color definitions account for Patran's weird
c                 ordering of colors.
c
      if ( intl_version .eq. 1 ) write(outfil,9111)
      if ( intl_version .eq. 2 ) write(outfil,9112)
c
c
c         ----------------
c         NOW CONVERT FILE
c         ----------------
c
c                 Discard first line
c
      read(infil, end=1100, fmt=9010) line
c
c                 Read a line from Patran hardcopy file; get record type
c
   25 continue
c
c
c
      jptr = 1
      read(infil, end=1100, fmt=9010) line
      call stripf( line, str_len, error)
      if ( error ) then
         write (iout,*) ' >> ERROR: line is blank. Skip to next line.'
         go to 25
      endif
      call hex_to_int( line, jptr, 2, irec, str_len)
c
 50   continue
c
c                 Check for valid record type.
c
      if (irec .le. 0 .or. (irec .gt. 22 .and. .not. irec.eq.255))
     &     go to 25
c
      go to (1010, 1020, 1030, 1040, 1050, 1060, 1070, 1080, 1090,
     &       1100, 1110, 1120, 1130, 1140, 1150, 1160, 1170, 1180,
     &       1190, 1200, 1210, 1220  ), irec
c
c       if it didn't match goto above, must be text (irec = 255)
c
      goto 1900
c
c                 Record Type 1: Short Vector
c                     Generate black line from current position to xy1.
c                     Reset current position to xy1.
c
 1010 continue
      call hex_to_int( line, jptr, 4, ix, str_len)
      call hex_to_int( line, jptr, 4, iy, str_len)
      xy(1) = real(ix)
      xy(2) = real(iy)
      call map(xy, xy1)
      write(outfil,9030) counter, xyc, xy1, 0, 0
      counter = counter + 1
      xyc(1) = xy1(1)
      xyc(2) = xy1(2)
      go to 2000
c
c                 Record Type 2: Long Vector
c                     Generate black line from xy1 to xy2.
c                     Reset current position to xy2.
c
 1020 continue
      call hex_to_int( line, jptr, 4, ix, str_len)
      call hex_to_int( line, jptr, 4, iy, str_len)
      xy(1) = real(ix)
      xy(2) = real(iy)
      call map(xy, xy1)
      call hex_to_int( line, jptr, 4, ix, str_len)
      call hex_to_int( line, jptr, 4, iy, str_len)
      xy(1) = real(ix)
      xy(2) = real(iy)
      call map(xy, xy2)
      write(outfil,9030) counter, xy1, xy2, 0, 0
      counter = counter + 1
      xyc(1) = xy2(1)
      xyc(2) = xy2(2)
      go to 2000
c
c                 Record Type 3: Dot
c                     Generate zero length black line at xy1.
c                     Reset current position to xy1.
c
 1030 continue
      call hex_to_int( line, jptr, 4, ix, str_len)
      call hex_to_int( line, jptr, 4, iy, str_len)
      xy(1) = real(ix)
      xy(2) = real(iy)
      call map(xy, xy1)
      write(outfil,9030) counter, xy1, xy1, 0, 0
      counter = counter + 1
      xyc(1) = xy1(1)
      xyc(2) = xy1(2)
      go to 2000
c
c                 Record Type 4: Fill Region (Not used)
c
 1040 continue
      go to 2000
c
c                 Record Type 5: Color
c                     Get foreground color. Ignore background color.
c
 1050 continue
      call hex_to_int( line, jptr, 4, icolor, str_len)
      go to 2000
c
c                 Record Type 6: Dashed Vector (Not used)
c
 1060 continue
      go to 2000
c
c                 Record Type 7: Raster Specification
c                     Save raster information
c                     xr     - Width of picture in pixels
c                     yr     - Height of picture in pixels
c                     ratior - Ratio of width of pixel to height of pixel
c                     pixinc - Height of scan line in pixels.
c
 1070 continue
      call hex_to_int (line, jptr, 4, ix, str_len)
      call hex_to_int (line, jptr, 4, iy, str_len)
c
c                   NOTE: in patran5, xr and yr are switched in the
c                          hardcopy file for the case of landscape
c                          page orientation.  Since all we will
c                          output from patran is landscape, we switch
c                          it back here.
c
      yr = real(ix)
      xr = real(iy)
c
      call hex_to_real (line, jptr, ratior, str_len)
      call hex_to_real (line, jptr, pixinc, str_len)
c
      realx = devy * xr * ratior / yr
      if (realx .gt. devx) then
          realy = devx * yr / xr / ratior
          devy = realy
      else
          devx = realx
      endif
      go to 2000
c
c                 Record Type 8: Frame Advance
c                     Close last scan line polygons and write them out.
c                     Put out end of frame information to close
c                     previous frame. Put out start of frame
c                     information for next frame. Skip close of
c                     frame information for first frame.
c                     Reset number of polygons to 0.
c
 1080 continue
      yl = 2 * ya - yh
      do i = 1, opoly
c
c                 Close current polygons.
c
          j = ghead
          ghead = space(j)
          space(j) = head(i)
          head(i) = j
          x(j) = xl(i)
          y(j) = yl
          j = ghead
          ghead = space(j)
          space(tail(i)) = j
          space(j) = 0
          tail(i) = j
          x(j) = xl(i+1)
          y(j) = yl
c
c                 Write out polygon except for blanks (color = 17)
c
          if (ocolor(i) .ne. 17) then
              write(outfil,9040) counter, ocolor(i)
              write(outfil,9050) counter, counter
              n1 = head(i)
 1084         n2 = space(n1)
              write(outfil,9060) counter, x(n1), y(n1), x(n2), y(n2),
     &             0, 127
              counter = counter + 1
              if (n2 .ne. tail(i)) then
                  n1 = n2
                  go to 1084
              endif
              n1 = tail(i)
              n2 = head(i)
              write(outfil,9060) counter, x(n1), y(n1), x(n2), y(n2),
     &             0, 127
              counter = counter + 1
              write(outfil,9070)
          endif
c
c                 Free up polygon list
c
          space(tail(i)) = ghead
          ghead = head(i)
      end do
c
      if (.not. first) then
          write(outfil,9130)
      endif
      if ( intl_version .eq. 1 ) then
         write(outfil,9121)
       else
         if ( .not. first ) write(outfil,9121)
      end if
      first = .false.
      opoly = 0
      go to 2000
c
c                 Record Type 9: End of Buffer
c
 1090 continue
      go to 25
c
c                 Record Type 10: End of Data
c                     Put out end of frame information. Close files.
c
 1100 continue
      write(outfil,9130)
      close(infil)
      close(outfil)
      write(iout,*) '>> Execution Complete'
      stop
c
c                 Record Type 11: Scale Specification (Not used)
c
 1110 continue
      go to 2000
c
c                 Record Type 12: Polygon Fill
c                     Create Interleaf polygon with appropriate
c                     fill color and invisible edges.
c
 1120 continue
      call hex_to_int (line, jptr, 2, npts, str_len)
      call varlen( line, jptr, npts*2, 4, inrec, str_len, infil, iout)
      write(outfil,9040) counter, icolor
      write(outfil,9050) counter , counter
      xy(1) = real(inrec(1))
      xy(2) = real(inrec(npts+1))
      call map(xy, xy1)
      do i = 2, npts
         xy(1) = real(inrec(i))
         xy(2) = real(inrec(npts+i))
         call map(xy, xy2)
         write(outfil,9060) counter, xy1, xy2, 0, 127
         counter = counter + 1
         xy1(1) = xy2(1)
         xy1(2) = xy2(2)
      enddo
      xy(1) = real(inrec(1))
      xy(2) = real(inrec(npts+1))
      call map(xy, xy2)
      write(outfil,9060) counter, xy1, xy2, 0, 127
      counter = counter + 1
      write(outfil,9070)
      go to 2000
c
c                 Record Type 13: Fill Box
c                     Create Interleaf polygon with appropriate
c                     fill color and invisible edges.
c
 1130 continue
c
c                 Skip this if the second record after this is
c                 a text record.  This avoids the black box used
c                 to erase the picture before the labels are put
c                 on the contours.
c
      read(infil, end=1100, fmt=9010) linetmp
      call stripf( linetmp, str_len_tmp, error)
      if (linetmp(1:2) .eq. 'FF') then
         line(1:) = linetmp(1:)
         jptr = 1
         str_len = str_len_tmp
         call hex_to_int( line, jptr, 2, irec, str_len)
         go to 2010
      endif
c
      call hex_to_int( line, jptr, 4, ix, str_len)
      call hex_to_int( line, jptr, 4, iy, str_len)
      xy(1) = real(ix)
      xy(2) = real(iy)
      call map(xy, xy1)
      call hex_to_int( line, jptr, 4, ix, str_len)
      call hex_to_int( line, jptr, 4, iy, str_len)
      xy(1) = real(ix)
      xy(2) = real(iy)
      call map(xy, xy2)
      write(outfil,9040) counter, icolor
      write(outfil,9050) counter, counter
      write(outfil,9060) counter,xy1(1), xy1(2), xy2(1), xy1(2), 0, 127
      counter = counter + 1
      write(outfil,9060) counter,xy2(1), xy1(2), xy2(1), xy2(2), 0, 127
      counter = counter + 1
      write(outfil,9060) counter,xy2(1), xy2(2), xy1(1), xy2(2), 0, 127
      counter = counter + 1
      write(outfil,9060) counter,xy1(1), xy2(2), xy1(1), xy1(2), 0, 127
      counter = counter + 1
      write(outfil,9070)
c
c         update new line
c
      line(1:) = linetmp(1:)
      jptr = 1
      str_len = str_len_tmp
      call hex_to_int( line, jptr, 2, irec, str_len)
      go to 2010
c
c                 Record Type 14: Scan Data Flag
c
 1140 go to 2000
c
c                 Record Type 15: Scan Line Data
c                     Create Interleaf polygons with appropriate
c                     fill color and invisible edges.
c
 1150 continue
      call scanline(npoly, ncolor, pixinc, ya, yh, line,
     &     jptr, irec, infil, iout)
      if (npoly .gt. 200) then
        write(*,*) '*** Error: Insufficient number of polygons ***'
        write(*,*) '    Recompile with at least', npoly, ' polygons'
        write(*,*) '    Deleting output file'
        close(infil)
        close(outfil,status='delete')
        stop
      endif
c
c                 Check if number of colors is changed from
c                 previous scan line.  If so, write out polygons.
c
      dopoly = npoly .ne. opoly
      do i = 1, min(opoly, npoly)
          dopoly = dopoly .or. (ncolor(i) .ne. ocolor(i))
      end do
      if ( dopoly ) then
          do i = 1, opoly
c
c                 Close current polygons.
c
              j = ghead
              ghead = space(j)
              space(j) = head(i)
              head(i) = j
              x(j) = xl(i)
              y(j) = yh
              j = ghead
              ghead = space(j)
              space(tail(i)) = j
              space(j) = 0
              tail(i) = j
              x(j) = xl(i+1)
              y(j) = yh
c
c                 Write out polygon except for blanks (color = 17)
c
              if (ocolor(i) .ne. 17) then
                  write(outfil,9040) counter, ocolor(i)
                  write(outfil,9050) counter, counter
                  n1 = head(i)
 1154             n2 = space(n1)
                  write(outfil,9060) counter, x(n1), y(n1), x(n2),
     &                 y(n2), 0, 127
                  counter = counter + 1
                  if (n2 .ne. tail(i)) then
                      n1 = n2
                      go to 1154
                  endif
                  n1 = tail(i)
                  n2 = head(i)
                  write(outfil,9060) counter, x(n1), y(n1), x(n2),
     &                 y(n2), 0, 127
                  counter = counter + 1
                  write(outfil,9070)
              endif
c
c                 Free up polygon list
c
              space(tail(i)) = ghead
              ghead = head(i)
          end do
      endif
c
c                 Get x positions on new scan line
c
      call getxpos(xl, npoly)
c
c                 Start new polygons
c
      if (dopoly) then
          opoly = npoly
          do i = 1, npoly
              ocolor(i) = ncolor(i)
              j = ghead
              ghead = space(j)
              head(i) = j
              x(j) = xl(i)
              y(j) = yh
              j = ghead
              ghead = space(j)
              tail(i) = j
              space(head(i)) = j
              space(j) = 0
              x(j) = xl(i+1)
              y(j) = yh
          end do
      endif
c
c                 Add to existing polygons
c
      do i = 1, npoly
          j = ghead
          ghead = space(j)
          space(j) = head(i)
          head(i) = j
          x(j) = xl(i)
          y(j) = ya
          j = ghead
          ghead = space(j)
          space(tail(i)) = j
          space(j) = 0
          tail(i) = j
          x(j) = xl(i+1)
          y(j) = ya
      end do
      go to 2010
c
c                 Record Type 16: Look-Up Table
c
c                     Black & White LUT were written by the
c                     document header format.
c
c                     For color doc, we read the Patran file LUT of
c                     RGB here, convert to percentages of CMYK
c                     & write to doc. We also force color zero
c                     to be black so that element lines on color fringe
c                     plots are black.
c
c                     also issue frame advance because Patran puts
c                     out a frame advance before the LUT is given.
c                     the first frame advance instruction for
c                     color is ignored.
c
 1160 continue
      call hex_to_int( line, jptr, 4, nstart, str_len )
      call hex_to_int( line, jptr, 4, ncol, str_len )
c      if (ncol .gt. 16) then
c          close(outfil,status='delete')
c          write(iout,9010) ' >> Number of colors greater than 16.'
c          write(iout,9010) '    Abandoning processing.'
c          stop
c      endif
      call varlen( line, jptr, ncol*3, 2, inrec, str_len, infil, iout)
c
      if ( intl_version .eq. 2 ) then
          write(outfil,9113)
          write(outfil,9114) 0, 0.0, 0.0, 0.0, 100.0
          do i = 1, ncol
             if (nstart+i-1 .eq. 0) cycle
             red      = 100.0 * real(inrec(3*i - 2)) / 255.0
             green    = 100.0 * real(inrec(3*i - 1)) / 255.0
             blue     = 100.0 * real(inrec(3*i    )) / 255.0
             cyan     = max(red,green,blue) - red
             magenta  = max(red,green,blue) - green
             yellow   = max(red,green,blue) - blue
             black    = 100.0 - max(red,green,blue)
             write(outfil,9114) nstart+i-1, cyan, magenta, yellow,
     &            black
          end do
c
          write(outfil,9115)
          write(outfil,9121)
      end if
      go to 2000
c
c                 Record Type 17: Continuation (ignore this)
c
 1170 continue
      go to 2000
c
c                 Record Type 18: Version
c                     Print out version number.
c
 1180 continue
      write(iout,9150) line(ptr:str_len)
      go to 2000
c
c                 Record Type 19: Unknown (ignore this)
c
 1190 continue
      go to 2000
c
c                 Record Type 20: Text Style (ignore this)
c
 1200 continue
      go to 2000
c
c                 Record Type 21: Text Scale (ignore this)
c
 1210 continue
      go to 2000
c
c                 Record Type 22: Text Rotation
c                      Find and store the text rotation
c
 1220 continue
      call hex_to_int (line, jptr, 4, idum, str_len)
      call hex_to_real (line, jptr, rotation, str_len)
      rotation = 360.0 - rotation
      go to 2000
c
c
c                 Record Type 255: Text
c
 1900 continue
c
c                    get start position for texxt
c
      call hex_to_int( line, jptr, 4, ix, str_len)
      call hex_to_int( line, jptr, 4, iy, str_len)
      xy(1) = real(ix)
      xy(2) = real(iy)
      call map(xy, xy1)
c
c                 Quote will escape certain characters in the text
c                 string so Interleaf can understand them. Output
c                 text in black.  Add 0.1 to y coordinate since
c                 Patran gives upper left coordinate of string.
c                 and Interleaf wants middle left coordinate.
c
      call hex_to_int( line, jptr, 2, num_char, str_len)
      string(1:) = line(jptr:jptr + num_char)
      call quote(string, string2, num_char, len2, maxlen2, iout)
      xy1(2) = xy1(2) + 0.1
      write(outfil,9090) counter, xy1, rotation, string2(1:len2)
      counter = counter + 1
      go to 2000
c
c
c                 Move pointer to next record
c
 2000 continue
      go to 25
 2010 continue
      go to 50
c
c                 end of interpreter loop for hardcopy file
c
c                 Formats
c
 9000 format(a,$)
 9010 format(a)
 9020 format('Patran_',a8)
 9022 format('>> $HOME environment variable not found.',/,
     &       '    Job terminated.' )
c 9030 format('(v6,',i6,',0,',4(f8.5,','),i3,',',i3,',1,0)')
 9030 format(' (v7,',i6,',0,,',4(f8.5,','),i3,',',i3,',0.125,0)')
 9040 format('(p8,',i6,',0,5,',i3,',0')
 9050 format(' (g9,',i6,',0',/,'  (g9,',i6,',0')
c 9060 format('   (v6,',i6,',0,',4(f8.5,','),i3,',',i3,',1,0)')
 9060 format('   (v7,',i6,',0,,',4(f8.5,','),i3,',',i3,',0.125,0)')
 9070 format('  )',/, ' )', /, ')')
 9080 format(20a4)
 9090 format('(t14,',i6,',0,',2(f8.5,','),'0,0,0,',f11.7,
     &       ',,wst:helvps8,',a,')')
 9100 format(' ***************************************************',/,
     &       ' *                                                 *',/,
     &       ' *     Patran to InterLeaf Hardcopy Translator     *',/,
     &       ' *                                                 *',/,
     &       ' *           For Interleaf Versions 5 or 6         *',/,
     &       ' *              For Release 6 of Patran            *',/,
     &       ' *               (last update: 2-3-97)             *',/,
     &       ' *                                                 *',/,
     &       ' ***************************************************',///)
c
 9111 format( '<!OPS, Version= 8.0>',/,
     & '<!Font Definitions,',/,
     & ' F2= Times 10,F3= Times 12 Bold,F4= Times 12,',/,
     & ' F5= Helvetica 14 Bold,F6= Symbols 12>',/,
     & '<!Page,',/,
     & ' Height=8.50 Inches,Width=11 Inches,Bottom Margin=1 Inches,',/,
     & ' Left Margin=1 Inches,Right Margin=1 Inches,Hyphenation=on,',/,
     & ' Consecutive Hyphens= 3,Revision Bar Placement= Left,',/,
     & ' Feathering= off>',/,
     & '<!Color Definitions,',/,
     & '   C7 =  0.00,  0.00,  0.00,',/,
     & '   C6 =  6.67,  6.67,  6.67,',/,
     & '  C13 = 13.33, 13.33, 13.33,',/,
     & '   C4 = 20.00, 20.00, 20.00,',/,
     & '  C12 = 26.67, 26.67, 26.67,',/,
     & '   C2 = 33.33, 33.33, 33.33,',/,
     & '  C11 = 40.00, 40.00, 40.00,',/,
     & '  C10 = 46.67, 46.67, 46.67,',/,
     & '  C15 = 53.33, 53.33, 53.33,',/,
     & '  C14 = 60.00, 60.00, 60.00,',/,
     & '   C5 = 66.67, 66.67, 66.67,',/,
     & '   C3 = 73.33, 73.33, 73.33,',/,
     & '   C9 = 80.00, 80.00, 80.00,',/,
     & '   C8 = 86.67, 86.67, 86.67,',/,
     & '   C1 = 93.33, 93.33, 93.33,',/,
     & '   C0 =100.00,100.00,100.00>',/,
     & '<!Class, "para",',/,
     & '  Top Margin=0.04 Inches,Bottom Margin=0.04 Inches,',/,
     & '  Font=F4@Z7@Lam,Line Spacing=1.1606 lines,',/,
     & '  Left Tab= 0/1*3 Inches,Composition=Optimum>',/,
     & '<!Master Frame,',/,
     & '  Name="page",Placement=At Anchor,Vertical Alignment=Top,',/,
     & '  Width=2 Inches,Width=Page Without Margins,',/,
     & '  Height=1 Inches,Height=Page Without Margins,',/,
     & '  Diagram=',/,
     & 'V11,',/,
     & '(g9,0,0,',/,
     & ' (E16,0,0,,5,1,1,0.0533333,1,15,0,0,1,0,0,0,',/,
     & '  1,5,127,7,0,0,7,0,1,1,0.0666667,0.06',/,
     & '  66667,6,6,0,0.0666667,6))>',/,
     & '<!End Declarations>' )
c
 9112 format( '<!OPS, Version = 8.0>',
     & '<!Document,',/,
     & '        Header Page = no,',/,
     & '        Final Output Device =   "ileaf",',/,
     & '        Default Printer =       "p3129c",',/,
     & '        Default Page Stream Name = "page">',/,
     & '<!Font Definitions,',/,
     & '        F2 = Times 10,',/,
     & '        F4 = Thames 10>',/,
     & '<!Page,',/,
     & '        Height =                8.50 Inches,',/,
     & '        Width =                 11 Inches,',/,
     & '        Bottom Margin =         1 Inches,',/,
     & '        Left Margin =           0.75 Inches,',/,
     & '        Right Margin =          1.25 Inches,',/,
     & '        Hyphenation =           on,',/,
     & '        Consecutive Hyphens =   3,',/,
     & '        Revision Bar Placement = Left,',/,
     & '        Feathering =            off>',/,
     & '<!Class, "para",',/,
     & '        Top Margin =            0.07 Inches,',/,
     & '        Bottom Margin =         0.07 Inches,',/,
     & '        Font =                  F4@Z7@Lam,',/,
     & '        Line Spacing =          1.3132 lines>',/,
     & '<!Master Frame,',/,
     & '        Name =                  "page",',/,
     & '        Placement =             At Anchor,',/,
     & '        Vertical Alignment =    Top,',/,
     & '        Width =                 0.41 Inches,',/,
     & '        Width =                 Page Without Margins,',/,
     & '        Height =                0.1366667 Inches,',/,
     & '        Height =                Page Without Margins,',/,
     & '        Diagram =',/,
     & 'V11,',/,
     & '(g9,0,0,',/,
     & ' (E16,0,0,,5,1,1,0.0533333,1,15,0,0,1,0,0,0,1,',/,
     & '  5,127,7,0,0,7,0,1,1,0.0666667,0.06',/,
     & '  66667,6,6,0,0.0666667,6))>')
c
 9113 format( '<!Color Definitions,' )
 9114 format( '  C',i3.3,' =',3(f6.2,','),f6.2,',')
 9115 format( '>',/,'<!End Declarations>' )
 9116 format(
     & '  C0 =    0.0,   0.0,   0.0, 100.0,',/,
     & '  C16 =   0.0, 100.0, 100.0, 0.0,',/,
     & '  C17 = 100.0,   0.0, 100.0, 0.0,',/,
     & '  C18 = 100.0, 100.0,   0.0, 0.0,',/,
     & '  C19 = 100.0,   0.0,   0.0, 0.0,',/,
     & '  C20 =   0.0, 100.0,   0.0, 0.0,',/,
     & '  C21 =   0.0,   0.0, 100.0, 0.0,',/,
     & '  C22 =   0.0,   0.0,   0.0, 0.0>'  )
c
 9121 format( '<para>', /,
     & '<|,1>', /,
     & '<Frame,', /,
     & '      Name =page, Placement =At Anchor,', /,
     & '      Vertical Alignment =Top,', /,
     & '      Width =Page Without Margins,',/,
     & '      Height =Page Without Margins,',/,
     & '      Diagram =',/,
     & '  V11,',/,
     & '(g9,1,0')
c
 9130 format( ') >')
 9140 format(' >> Interleaf Document: ', a)
 9150 format(' >> Patran Version: ', a)
      end
c
c *****************************************************************
c *                                                               *
c *      s u b r o u t i n e  -- v a r l e n                      *
c *                                                               *
c *****************************************************************
c
      subroutine varlen( line, ptr, num_vals, size, inrec, str_len,
     &     infil, iout)
      implicit integer (a-z)
      integer inrec(*)
      character *(*) line
      logical error
c
c
      counter = 1
      do while (.true.)
         call hex_to_int( line, ptr, size, inrec(counter), str_len)
         counter = counter + 1
         if (counter .gt. num_vals) exit
         if (ptr .gt. str_len) then
 10         continue
            read(infil, end=1000, fmt=9020) line
            call stripf( line, str_len, error )
            if ( error ) then
               write (iout,*) ' >> ERROR: line is blank. Skipping to'
               write (iout,*) ' >> next line.'
               go to 10
            endif
            ptr = 1
         endif
      enddo
c
      return
c
c         reached end of file
c
 1000 continue
      write (iout, *) ' >> fatal error: end of file reached before'
      write (iout, *) ' >>    end of record found.  Aborting.'
      stop
c
 9020 format(a)
      end
c
c *****************************************************************
c *                                                               *
c *      s u b r o u t i n e  -- m a p                            *
c *                                                               *
c *****************************************************************
c
      subroutine map(xy, xym)
c
c                 Map coordinates in hardcopy file system (xy)
c                 to coordinates of output system (xym)
c
      real xy(2), xym(2)
      common /device/ xr, yr, ratior, pixinc, devx, devy
      xym(1) = xy(1) * devx / xr
      xym(2) = devy - xy(2) * devy / yr
      return
      end
c *****************************************************************
c *                                                               *
c *      s u b r o u t i n e  -- q u o t e                        *
c *                                                               *
c *****************************************************************
c
      subroutine quote(strng1, strng2, len, len2, maxlen2, iout )
c
c                 Quote special characters ( < > ( ) , \  sp )
c                 with a backslash (\) so Interleaf can interpret
c                 them correctly
c
      character*(*) strng1, strng2
      len2 = 0
      do i = 1, len
          if ((strng1(i:i) .eq. '<') .or.
     &        (strng1(i:i) .eq. '>') .or.
     &        (strng1(i:i) .eq. '(') .or.
     &        (strng1(i:i) .eq. ')') .or.
     &        (strng1(i:i) .eq. ',') .or.
     &        (strng1(i:i) .eq. '\') .or.
     &        (strng1(i:i) .eq. ' ')) then
              len2 = len2 + 1
              if ( len2 .ge. maxlen2 ) then
                write(iout,9000) maxlen2
                stop
              end if
              strng2(len2:len2) = '\'
          endif
          len2 = len2 + 1
          if ( len2 .ge. maxlen2 ) then
            write(iout,9000) maxlen2
            stop
          end if
          strng2(len2:len2) = strng1(i:i)
      end do
      return
c
 9000 format(/,'>> Fatal error: the string length generated',
     &       /,'                for Interleaf file exceeds the',
     &       /,'                limit of: ',i5,' characters.',
     &       /,'                Shorten Patran results titles',
     &       /,'                and re-try! Job terminated.' )
c
      end
c
c *****************************************************************
c *                                                               *
c *      s u b r o u t i n e  -- s t r i p f                      *
c *                                                               *
c *****************************************************************
c
      subroutine stripf( string, str_len, error )
      implicit integer (a-z)
      character *(*) string, copy*256
      logical error
      save line
      data line /1/
c
c             strip leading and ending blanks from string and return it,
c             along with length of string
c
      line = line + 1
      error = .false.
      last = len(string)
      copy(1:last) = string(1:last)
      start = 1
      do while (string(start:start) .eq. ' ')
         start = start + 1
         if (start .gt. last) go to 1000
      enddo
      do while (string(last:last) .eq. ' ')
         last = last - 1
         if (last .lt. start) go to 1000
      enddo
c
      string(1:) = copy(start:last)
      str_len = last - start + 1
c
      return
c
 1000 continue
      error = .true.
      return
      end
c
c *****************************************************************
c *                                                               *
c *      s u b r o u t i n e  -- s c a n l i n e                  *
c *                                                               *
c *****************************************************************
c
      subroutine scanline(npoly, ncolor, pixinc, ya, yh, line,
     &     jptr, irec, infil, iout)
c
c   Read in scan lines. Combine scan lines with same y level
c   into a single scan line. Return list of colors and
c   x positions for polygons and number of polygons.
c
      character*256 line
      common /xlpcom/ xlp(201)
      dimension ncolor(200), inrec(50000), xy(2), xy1(2), xy2(2)
      logical first, error
      integer str_len
c
c            Initialize
c
      npoly = 0
      first = .true.
c
  100 continue
c
c            Map x and y positions from scan line data, and get number of
c            pixels
c
      call hex_to_int( line, jptr, 4, ix, str_len )
      call hex_to_int( line, jptr, 4, iy, str_len )
      xy(2) = real(iy)
      xy(1) = real(ix)
      call map(xy, xy1)
      call hex_to_int( line, jptr, 4, ix, str_len )
      xy(1) = real(ix)
      xy(2) = xy(2) + pixinc / 2
      call map(xy, xy2)
      call hex_to_int( line, jptr, 4, npix, str_len )
c
c            Save y position of first scan line.
c
      if (first) ypos = xy1(2)
c
c            Check y position of new scan line against first scan line.
c            Add blank polygon between scan lines on the same y level.
c
      if (ypos .ne. xy1(2)) then
        return
      else if (first) then
        first = .false.
      else
        npoly = npoly + 1
        ncolor(npoly) = 17
      endif
c
c            Find number of colors in scan line and x positions of
c            color changes.
c
      ya = xy1(2)
      yh = xy2(2)
      xs = xy1(1)
      xf = xy2(1)
      call varlen( line, jptr, npix, 4, inrec, str_len, infil, iout)
      npoly = npoly + 1
      ncolor(npoly) = inrec(1)
      xlp(npoly) = xs
      do i = 1, npix
        if (inrec(i) .ne. ncolor(npoly)) then
          npoly = npoly + 1
          ncolor(npoly) = inrec(i)
          xlp(npoly) = xs + (xf-xs) * float(i-1) / npix
        endif
      end do
      xlp(npoly+1) = xf
c
c            Go get next line
c
 200  continue
      jptr = 1
      read(infil, end=1000, fmt=9020) line
      call stripf( line, str_len, error)
      if ( error ) then
         write (iout,*) ' >> ERROR: line is blank. Skip to next line.'
         go to 200
      endif
      call hex_to_int( line, jptr, 2, irec, str_len)
c
c            Return if new line is not a scan line record.
c
      if (irec .ne. 15) return
      go to 100
c
c         reached end of file
c
 1000 continue
      write (iout, *) ' >> fatal error: end of file reached before'
      write (iout, *) ' >>    end of record found.  Aborting.'
      stop
c
 9020 format(a)
      end
c
c *****************************************************************
c *                                                               *
c *      s u b r o u t i n e  -- g e t x p o s                    *
c *                                                               *
c *****************************************************************
c
      subroutine getxpos(xl, npoly)
c
c             Return x positions of polygons
c
      common /xlpcom/ xlp(201)
      dimension xl(201)
      do i = 1, npoly + 1
        xl(i) = xlp(i)
      end do
      return
      end
c
c *****************************************************************
c *                                                               *
c *      s u b r o u t i n e  -- h e x _ t o _ i n t              *
c *	                                                          *
c *          takes hex numbers as character data and converts     *
c *	     then into an integer.                                *
c *                                                               *
c *****************************************************************
c
      subroutine hex_to_int( string, ptr, num_hexchars, inum, len )
      implicit integer (a-z)
      character *(*) string, char*1
      data intzero, intnine, inta, intf / 48, 57, 65, 70 /
c
c       string       = current line of characters to be treated as hex
c       ptr          = pointer to current place in string to process
c       num_hexchars = number of chars of hex to read
c       inum         = returned integer
c       len          = length of initial string
c
      inum = 0
      do i = ptr, num_hexchars+ptr-1
c
         if (i .gt. len) then
            write (*,9010)
            stop
         endif
c
         char = string(i:i)
         char_num = ichar(char)
         if (char_num .ge. intzero .and. char_num .le. intnine) then
            inum = inum * 16 + char_num - intzero
         else if (char_num .ge. inta .and. char_num .le. intf) then
            inum = inum * 16 + char_num - inta + 10
         else
            write (*,9000) char
            stop
         endif
c
      enddo
      ptr = ptr + num_hexchars
c
c
      return
 9000 format(/,' >>> ERROR: character ',a1,' not recognized for',
     &       /,'            integer. Aborting Program.',/)
 9010 format(/,' >>> ERROR: attempt to access character beyond end',
     &       /,'            of line. Aborting Program.',/)
      end
c
c *****************************************************************
c *                                                               *
c *      s u b r o u t i n e  -- h e x _ t o _ r e a l            *
c *	                                                          *
c *          takes hex numbers as character data and converts     *
c *	     then into a real number.                             *
c *                                                               *
c *****************************************************************
c
      subroutine hex_to_real( string, ptr, rnum, len )
      implicit integer (a-z)
      character *(*) string
      real rnum
c
      call hex_to_int( string, ptr,   4, numerator, len)
      call hex_to_int( string, ptr, 4, denominator, len)
c
      rnum = real (numerator) / real (denominator)
c
c
      return
      end


text:
C     This File is Automatically generated by ALOHA
C     The process calculated in this file is:
C     ProjP(2,1)
C
      SUBROUTINE FFS2_0(F1, F2, S3, COUP,VERTEX)
      IMPLICIT NONE
      COMPLEX*16 CI
      PARAMETER (CI=(0D0,1D0))
      COMPLEX*16 S3(*)
      COMPLEX*16 TMP7
      COMPLEX*16 F1(*)
      COMPLEX*16 F2(*)
      COMPLEX*16 VERTEX
      COMPLEX*16 COUP
      TMP7 = (F1(5)*F2(5)+F1(6)*F2(6))
      VERTEX = COUP*(-CI * TMP7*S3(3))
      END


text:
module normal_mode

use get_constants

implicit none
double precision :: hbar, amu2kg, C
!---------------------------------------------------------------------
parameter (hbar = 1.054571725d-14)                      ! (kg*Ang**2/s**2)*s
parameter (amu2kg = 1.660539d-27)                       ! kg
parameter (C = 299792458*100.d0)                        ! speed of light in cm/s
!---------------------------------------------------------------------
contains
!---------------------------------------------------------------------
subroutine get_cart_disp(file_id,numbr,symb,chrg,coord,freq,eig_v_amu,n)

implicit none
integer,intent(in)                 :: file_id,numbr
character(len=15),intent(in)       :: symb(numbr)
double precision,intent(in)        :: coord(numbr,3),         &
                                      chrg(numbr),freq,       &
                                      eig_v_amu(3*numbr)
integer,intent(in),optional        :: n
!---------------------------------------------------------------------
character(len=32)                  :: output
integer                            :: i,j,point_pos
double precision                   :: coord_ang_eq(3*numbr),  &
                                      eig_v_to_kg(3*numbr),   &
                                      qmin,qmax,dq,q,qd,omega,          &
                                      displacement(3*numbr),  &
                                      cartesian_displacement(3*numbr)
!---------------------------------------------------------------------
if (present(n)) write(file_id,12) n

!~~~ Transform coordinates from au to Angstrom
coord_ang_eq = 0.0d0

do i = 1, numbr
 coord_ang_eq(i*3-2) = coord(i,1)/ang2bohr
 coord_ang_eq(i*3-1) = coord(i,2)/ang2bohr
 coord_ang_eq(i*3)   = coord(i,3)/ang2bohr
end do

!========== DIMENSION OF EIG_V_TO_KG ==============!
!== sqrt(1/amu)*sqrt(1/kg/amu)=sqrt(1/kg)
eig_v_to_kg = eig_v_amu*sqrt(1/amu2kg)

!== Transform vibrational frequency to Hertz (s**(-1))
omega = 2.0d0*pi*C*freq

!======= DIMENSIONLESS NORMAL MODE LOOP
!======= (LOOP OVER DISPLACEMENTS Q
!======  TO GENERATE CARTESIAN GEOMETRIES) =========!

!== qmin and qmax are displacement sampling borders
Qmin = -5.0d0
Qmax =  5.0d0

!== dq is a displacement step along the RC
dq   = (qmax - qmin)/20

do i = 0, 20
!== q is the displacement at iteration # I
 q = qmin + dble(i)*dq

!================ DIMENSION OF QD ===================!
!== sqrt(kg*(Ang**2)*(s**-1)/(s**-1)) = sqrt(kg)*Ang

 qd = sqrt(hbar/omega)*q

!===== NORMAL MODES TO CARTESIAN TRANSFORMATION =====!
!============= DIMENSION OF RC_DISP =================!
!== sqrt(1/kg)*sqrt(kg)*Ang = Ang

  displacement = eig_v_to_kg*qd

!========== GEOMETRY OUTPUT IN XYZ FORMAT ===========!

cartesian_displacement = coord_ang_eq + displacement

!*** Write geometries in file at each loop step ****!

write(file_id,10) i

do j = 1, numbr
 write(file_id,11) symb(j),chrg(j),&
 cartesian_displacement(j*3-2),        &
 cartesian_displacement(j*3-1),        &
 cartesian_displacement(j*3)
end do
!************************ End **********************!

end do

!=================== END LOOP ======================!

!************ Write format specification ***********!

10 FORMAT(/,'Geometry # ',I2)
11 FORMAT(A10,4X,F4.1,3X,F17.9,3X,F17.9,4X,F17.9)
12 FORMAT(/,'A new imaginary mode is found. The mode # is Q',I2)

end subroutine get_cart_disp
!---------------------------------------------------
end module normal_mode

max_stars_repo_name: svarganov/NAST

max_issues_repo_name: svarganov/NAST

max_forks_repo_name: svarganov/NAST


text:
!***************************************************************************************************
! xnet_integrate_be.f90 10/18/17
! Backward Euler solver
!
! The routines in this file perform the Backward Euler time integration for the thermonuclear
! reaction network.
!***************************************************************************************************

Module xnet_integrate_be
  Implicit None

Contains

  Subroutine solve_be(kstep,its)
    !-----------------------------------------------------------------------------------------------
    ! This routine handles the potential failure of an individual Backward Euler step. Repeated calls
    ! to the BE step integrator are made with successivley smaller timesteps until success is achieved
    ! or ktsmx trials fail. The abundances are evolved using a Newton-Raphson iteration scheme to
    ! solve the equation (yt(i)-y(i))/tdel = ydot(i), where y(i) is the abundance at the beginning of
    ! the iteration, yt(i) is the trial abundance at the end of the timestep, ydot(i) is the time
    ! derivative of the trial abundance calculated from reaction rates and tdel is the timestep.
    !-----------------------------------------------------------------------------------------------
    Use xnet_abundances, Only: y, yo, yt, xext
    Use xnet_conditions, Only: t, to, tt, tdel, tdel_next, t9, t9o, t9t, rho, rhoo, rhot, &
      yeo, ye, yet, nt, nto, ntt, t9rhofind
    Use xnet_controls, Only: idiag, iheat, kitmx, kmon, ktot, lun_diag, lun_stdout, tdel_maxmult, &
      & szbatch, zb_lo, zb_hi
    Use xnet_timers, Only: xnet_wtime, start_timer, stop_timer, timer_tstep
    Implicit None

    ! Input variables
    Integer, Intent(in) :: kstep

    ! Input/Output variables
    Integer, Intent(inout) :: its(zb_lo:zb_hi) ! On input,  = 0 indicates active zone
                                               ! On output, = 1 if zone fails to converge

    ! Local variables
    Integer, Parameter :: ktsmx = 10
    Integer :: kts, izb, izone
    Integer :: inr(zb_lo:zb_hi)
    Integer :: mykts(zb_lo:zb_hi)
    Logical :: lzstep(zb_lo:zb_hi)

    start_timer = xnet_wtime()
    timer_tstep = timer_tstep - start_timer

    ! If the zone has previously converged or failed, do not iterate
    Do izb = zb_lo, zb_hi
      If ( its(izb) /= 0 ) Then
        inr(izb) = -1
        lzstep(izb) = .false.
      Else
        inr(izb) = 0
        lzstep(izb) = .true.
      EndIf
    EndDo

    !-----------------------------------------------------------------------------------------------
    ! For each trial timestep, tdel, the NR iteration is attempted.
    ! The possible results for a timestep are a converged set of yt or a failure to converge.
    ! If convergence fails, retry with the trial timestep reduced by tdel_maxmult.
    !-----------------------------------------------------------------------------------------------
    mykts = 0
    Do kts = 1, ktsmx

      ! Attempt Backward Euler integration over desired timestep
      Call step_be(kstep,inr)

      Do izb = zb_lo, zb_hi

        ! If integration fails, reset abundances, reduce timestep and retry.
        If ( inr(izb) == 0 ) Then
          tdel(izb) = tdel(izb) / tdel_maxmult
          tt(izb) = t(izb) + tdel(izb)
          yet(izb) = ye(izb)
          yt(:,izb) = y(:,izb)
          mykts(izb) = kts+1

          ! Record number of NR iterations
          If ( its(izb) == 0 ) Then
            kmon(2,izb) = kitmx + 1
            ktot(2,izb) = ktot(2,izb) + kitmx + 1
          EndIf

        ! If integration is successfull, flag the zone for removal from zone loop
        ElseIf ( inr(izb) > 0 ) Then
          mykts(izb) = kts

          ! Record number of NR iterations
          If ( its(izb) == 0 ) Then
            kmon(2,izb) = inr(izb)
            ktot(2,izb) = ktot(2,izb) + inr(izb)
          EndIf
        EndIf
      EndDo

      ! Reset temperature and density for failed integrations
      lzstep = ( inr == 0 )
      Call t9rhofind(kstep,tt,ntt,t9t,rhot,mask_in = lzstep)
      If ( iheat > 0 ) Then
        Do izb = zb_lo, zb_hi
          If ( inr(izb) == 0 ) Then
            t9t(izb) = t9(izb)
          EndIf
        EndDo
      EndIf

      ! Log the failed integration attempts
      If ( idiag >= 2 ) Then
        Do izb = zb_lo, zb_hi
          If ( inr(izb) == 0 ) Then
            izone = izb + szbatch - zb_lo
            Write(lun_diag,"(a,i5,i3,3es12.4)") 'BE TS Reduce',izone,kts,tt(izb),tdel(izb),tdel_maxmult
          EndIf
        EndDo
      EndIf

      ! Test if all zones have converged
      If ( .not. any( lzstep ) ) Exit
    EndDo

    ! Mark TS convergence only for zones which haven't previously failed or converged
    Do izb = zb_lo, zb_hi
      If ( inr(izb) > 0 ) Then
        nto(izb) = nt(izb)
        nt(izb) = ntt(izb)
        to(izb) = t(izb)
        t(izb) = tt(izb)
        t9o(izb) = t9(izb)
        t9(izb) = t9t(izb)
        rhoo(izb) = rho(izb)
        rho(izb) = rhot(izb)
        yeo(izb) = ye(izb)
        ye(izb) = yet(izb)
        yo(:,izb) = y(:,izb)
        y(:,izb) = yt(:,izb)
        tdel_next(izb) = tdel(izb) * tdel_maxmult
      ElseIf ( inr(izb) == 0 ) Then
        its(izb) = 1
      EndIf
    EndDo

    ! Log TS success/failure
    Do izb = zb_lo, zb_hi
      izone = izb + szbatch - zb_lo
      If ( inr(izb) > 0 ) Then
        If ( idiag >= 2 ) Write(lun_diag,"(a,2i5,2i3)") &
          & 'BE TS Success',kstep,izone,mykts(izb),inr(izb)
      ElseIf ( inr(izb) == 0 ) Then
        If ( idiag >= 0 ) Write(lun_diag,"(a,2i5,4es12.4,2i3)") &
          & 'BE TS Fail',kstep,izone,t(izb),tdel(izb),t9t(izb),rhot(izb),inr(izb),mykts(izb)
        Write(lun_stdout,*) 'Timestep retrys fail after ',mykts(izb),' attempts'
      EndIf
    EndDo

    Do izb = zb_lo, zb_hi
      If ( inr(izb) >= 0 ) Then
        kmon(1,izb) = mykts(izb)
        ktot(1,izb) = ktot(1,izb) + mykts(izb)
      EndIf
    EndDo

    stop_timer = xnet_wtime()
    timer_tstep = timer_tstep + stop_timer

    Return
  End Subroutine solve_be

  Subroutine step_be(kstep,inr)
    !-----------------------------------------------------------------------------------------------
    ! This routine attempts to integrate a single Backward Euler step for the timestep tdel.
    ! If successful, inr = 1
    !-----------------------------------------------------------------------------------------------
    Use nuclear_data, Only: ny, aa, nname
    Use xnet_abundances, Only: y, ydot, yt, xext
    Use xnet_conditions, Only: cv, rhot, t9, t9dot, t9t, tdel, nh
    Use xnet_controls, Only: iconvc, idiag, iheat, ijac, kitmx, lun_diag, tolc, tolm, tolt9, ymin, &
      & szbatch, zb_lo, zb_hi, iscrn
    Use xnet_integrate, Only: cross_sect, yderiv
    Use xnet_jacobian, Only: jacobian_bksub, jacobian_decomp, jacobian_build, jacobian_solve
    Use xnet_timers, Only: xnet_wtime, start_timer, stop_timer, timer_nraph
    Use xnet_types, Only: dp
    Implicit None

    ! Input variables
    Integer, Intent(in) :: kstep

    ! Input/Output variables
    Integer, Intent(inout) :: inr(zb_lo:zb_hi) ! On input,  = 0 indicates active zone
                                               !            =-1 indicates inactive zone
                                               ! On output, > 0 indicates # NR iterations if converged

    ! Local variables
    Integer :: irdymx, idymx
    Integer :: i, k, kit, izb, izone
    Real(dp) :: testc, testc2, testm, testn(zb_lo:zb_hi), toln(zb_lo:zb_hi)
    Real(dp) :: xtot(zb_lo:zb_hi), xtot_init(zb_lo:zb_hi), rdt(zb_lo:zb_hi), mult(zb_lo:zb_hi)
    Real(dp) :: yrhs(ny,zb_lo:zb_hi), dy(ny,zb_lo:zb_hi), reldy(ny)
    Real(dp) :: t9rhs(zb_lo:zb_hi), dt9(zb_lo:zb_hi), relt9
    Logical :: iterate(zb_lo:zb_hi), eval_rates(zb_lo:zb_hi), rebuild(zb_lo:zb_hi)

    start_timer = xnet_wtime()
    timer_nraph = timer_nraph - start_timer

    ! Create mask for active zone integrations
    iterate = ( inr == 0 )

    ! Calculate initial total mass fraction
    Do izb = zb_lo, zb_hi
      If ( iterate(izb) ) Then
        xtot_init(izb) = sum(aa*y(:,izb)) + xext(izb) - 1.0
        rdt(izb) = 1.0 / tdel(izb)
        mult(izb) = -1.0
      Else
        xtot_init(izb) = 0.0
        rdt(izb) = 0.0
        mult(izb) = 0.0
      EndIf
    EndDo

    ! The Newton-Raphson iteration occurs for at most kitmx iterations.
    Do kit = 1, kitmx

      ! Rebuild and update LU factorization of the jacobian every ijac iterations
      rebuild = ( iterate .and. mod(kit-1,ijac) == 0 )

      ! If thermodynamic conditions are changing, rates need to be udpated
      If ( iheat > 0 ) Then
        eval_rates = iterate
      ElseIf ( kit == 1 ) Then
        eval_rates = ( iterate .and. nh(zb_lo:zb_hi) > 1 )
      Else
        eval_rates = .false.
      EndIf

      ! Calculate the reaction rates and abundance time derivatives
      Call cross_sect(mask_in = eval_rates)
      Call yderiv(mask_in = iterate)
      Call jacobian_build(diag_in = rdt,mult_in = mult,mask_in = rebuild)
      Call jacobian_decomp(kstep,mask_in = rebuild)

      ! Calculate equation to zero
      Do izb = zb_lo, zb_hi
        If ( iterate(izb) ) Then
          yrhs(:,izb) = (y(:,izb)-yt(:,izb))*rdt(izb) + ydot(:,izb)
          If ( iheat > 0 ) t9rhs(izb) = (t9(izb)*rdt(izb)-t9t(izb)*rdt(izb)) + t9dot(izb)
        EndIf
      EndDo
      If ( idiag >= 4 ) Then
        Do izb = zb_lo, zb_hi
          If ( iterate(izb) ) Then
            izone = izb + szbatch - zb_lo
            Write(lun_diag,"(a3,2i5,es14.7)") 'RHS',kstep,izone,rdt(izb)
            Write(lun_diag,"(a5,4es23.15)") (nname(i),yrhs(i,izb),ydot(i,izb),yt(i,izb),y(i,izb),i=1,ny)
            If ( iheat > 0 ) Write(lun_diag,"(a5,4es23.15)") 'T9',t9rhs(izb),t9dot(izb),t9t(izb),t9(izb)
          EndIf
        EndDo
      EndIf

      ! Solve the jacobian and calculate the changes in abundances, dy
      !Call jacobian_solve(kstep,yrhs,dy,t9rhs,dt9,mask_in = iterate)
      !Call jacobian_decomp(kstep,mask_in = iterate)
      Call jacobian_bksub(kstep,yrhs,dy,t9rhs,dt9,mask_in = iterate)

      ! Evolve the abundances and calculate convergence tests
      Do izb = zb_lo, zb_hi
        If ( iterate(izb) ) Then
          Do k = 1, ny
            yt(k,izb) = yt(k,izb) + dy(k,izb)
            If ( yt(k,izb) < ymin ) Then
              yt(k,izb) = 0.0
              reldy(k) = 0.0
            Else
              reldy(k) = abs(dy(k,izb) / yt(k,izb))
            EndIf
          EndDo
          If ( iheat > 0 ) Then
            t9t(izb) = t9t(izb) + dt9(izb)
            If ( abs(t9t(izb)) > tiny(0.0) ) Then
              relt9 = abs(dt9(izb) / t9t(izb))
            Else
              relt9 = 0.0
            EndIf
          Else
            relt9 = 0.0
          EndIf
          If ( idiag >= 4 ) Then
            izone = izb + szbatch - zb_lo
            irdymx = maxloc(reldy,dim=1)
            idymx = maxloc(dy(:,izb),dim=1)
            Write(lun_diag,"(a3,2i5,i3,2(a5,2es23.15))") &
              & ' dY',kstep,izone,kit,nname(idymx),dy(idymx,izb),y(idymx,izb),nname(irdymx),reldy(irdymx),y(irdymx,izb)
            If ( idiag >= 5 ) Write(lun_diag,"(a5,5es12.4)") &
              & (nname(k),yt(k,izb),dy(k,izb),reldy(k),(aa(k)*dy(k,izb)),(aa(k)*yt(k,izb)),k=1,ny)
            If ( iheat > 0 ) Write(lun_diag,"(a3,2i5,i3,5x,2es23.15,5x,es12.4)") &
              & 'dT9',kstep,izone,kit,dt9(izb),t9t(izb),relt9
          EndIf

          !-----------------------------------------------------------------------------------------
          ! There are 3 included convergence tests:
          ! testc which measures relative changes,
          ! testc2 which measures total abundance changes, and
          ! testm which tests mass conservation.
          !-----------------------------------------------------------------------------------------
          testc  = sum(reldy)
          testc2 = sum(aa*dy(:,izb))
          xtot   = sum(aa*yt(:,izb)) + xext(izb) - 1.0
          testm  = xtot(izb) - xtot_init(izb)
          If ( idiag >= 3 ) Write(lun_diag,"(a,3i5,3es14.6)") 'NR',kstep,izone,kit,testm,testc,testc2

          !-----------------------------------------------------------------------------------------
          ! testc is the most stringent test, and requires the most iterations.
          ! testm is the most lax, and therefore the fastest, often requiring only one iteration.
          ! Considering the uncertainties of the reaction rates, it is doubtful that the
          ! increased precision of testc is truly increased accuracy.
          !-----------------------------------------------------------------------------------------
          ! Ordinarily, test for true convergence
          If ( iconvc /= 0 ) Then
            testn(izb) = testc
            toln(izb) = tolc

          ! Otherwise, use mass conservation for convergence condition
          Else
            testn(izb) = testm
            toln(izb) = tolm
          EndIf

          ! If converged, exit NR loop
          If ( abs(testn(izb)) <= toln(izb) .and. relt9 < tolt9 ) Then
            inr(izb) = kit
            iterate(izb) = .false.
          EndIf
        EndIf
      EndDo

      ! Check that all zones are converged
      If ( .not. any(iterate(:)) ) Exit
    EndDo

    If ( idiag >= 2 ) Then
      Do izb = zb_lo, zb_hi
        izone = izb + szbatch - zb_lo
        If ( inr(izb) > 0 ) Then
          Write(lun_diag,"(a,3i5,3es12.4)") 'Conv',kstep,izone,inr(izb),xtot(izb),testn(izb),toln(izb)
        ElseIf ( inr(izb) == 0 ) Then
          Write(lun_diag,"(a,3i5,2es10.2)") 'BE Failure',izone,inr(izb),kitmx,xtot(izb),testn(izb)
        EndIf
      EndDo
    EndIf

    stop_timer = xnet_wtime()
    timer_nraph = timer_nraph + stop_timer

    Return
  End Subroutine step_be

End Module xnet_integrate_be

max_stars_repo_name: starkiller-astro/XNet

max_issues_repo_name: starkiller-astro/XNet

max_forks_repo_name: starkiller-astro/XNet


text:
apb_if.sv
apb_pkg.sv

//-parseinfo macro
//-Epretty blat

+incdir+$SVUNIT_INSTALL/svunit_base/util
+incdir+../../../src

../../../src/svmock_pkg.sv

max_stars_repo_name: nosnhojn/svmock

max_issues_repo_name: nosnhojn/svmock

max_forks_repo_name: tudortimi/svmock


text:
! { dg-do compile }
!
! PR fortran/33231
!
! Elemental function:
! Intent OUT/INOUT dummy: Actual needs to be an array
! if any actual is an array
!
program prog
implicit none
integer :: i, j(2)
call sub(i,1,2) ! OK, only scalar
call sub(j,1,2) ! OK, scalar IN, array OUT
call sub(j,[1,2],3) ! OK, scalar & array IN, array OUT
call sub(j,[1,2],[1,2]) ! OK, all arrays

call sub(i,1,2) ! OK, only scalar
call sub(i,[1,2],3) ! { dg-error "is a scalar" }
call sub(i,[1,2],[1,2]) ! { dg-error "is a scalar" }
contains
elemental subroutine sub(a,b,c)
  integer :: func, a, b, c
  intent(in) :: b,c
  intent(out) :: a
  a = b +c
end subroutine sub
end program prog

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
While these services have been viewed as the typical rentacop services, the state of California has changed the regulations as of 2006 (effective in Davis as of http://www.bsis.ca.gov/industries_regulated/psoact.shtml January 1st, 2011) to require all PSOs (private security officers) to obtain PSO/Guard Cards. This includes Door and Roaming Security at local drinking/dancing establishments.  These PSOs are regulated by the state, must maintain a clean criminal history/background check and DMV record.

There are several different types of PSOs, and each has its own guidelines for what they may and may not do depending on your level of PSO training.

Each Bar/Club is required to staff security that has a current Guard Card licensed by the state of Californias http://www.bsis.ca.gov/ BSIS. Due to the high rate of turnover at bars/clubs, the cost is paid by the employee and normally not the establishment. However, all security personnel in all fields are required to obtain the license.

The cost for the license varies, as does the training, depending on which type you are qualifying for. The base level http://www.bsis.ca.gov/forms_pubs/guard_fact.shtml Guard Card requires approximately 40 hours of class time, an extensive background check by the http://oag.ca.gov/ state and http://www.justice.gov/ federal Department of Justice and has an average cost of about $150.00 which includes the background checks and a http://en.wikipedia.org/wiki/Live_Scan livescan which places the individual permanently on file with all law enforcement. Any business or establishment which knowingly hires and keeps in their employ any individual in a security field who has not obtained or registered for a guard card can be fined up to $5,000.00 while the individual may be fined up to $1,500.00 for working under false pretenses.

Individuals who wish to perform Private Security functions (private parties, personal security services, etc.) must obtain a minimum of a Level 2 PSO card, have a minimum of two (2) years of security services background and obtain an additional background check through the state and federal government annually.

 Security Guards and Patrols
These are often utilized for events board special events. Businesses, construction sites, Apartments apartment communities, or Neighborhood Associations homeowners associations may also employ such services to have stationary guards or periodic patrols on a longterm basis.
  Maguid Security
  Patrol Plus Private Security
  Summit Security

 Auto Security Systems
Businesses that install car alarms.

  Mobile Connections

 Building Security Systems
Businesses that install and/or monitor burglar alarm systems or closed circuit TV systems for buildings. (See Davis Municipal Code/4 Davis Municipal Code, Chapter 4 for city information on burglar alarms.)

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
! ---------------------------------------------------------------------
! Fortran-90 versions of machine-constant routines R1MACH, D1MACH, I1MACH
!
! Usage:  In whatever routine needed, put the statement
!         USE RDI1MACH_f90, ONLY : R1MACH, D1MACH, I1MACH
!         (list only the x1MACH routines you actually use after ONLY)
! ---------------------------------------------------------------------

MODULE RDI1MACH_f90

! ---------------------------------------------------------------------
!  {R,D,I}1MACH revisited: no more uncommenting DATA statements
!
!  The widely-used original routines were modified to use Fortran-90
!  intrinsic functions.  This was not completely possible with I1MACH,
!  which returns some parameters (logical unit numbers of standard
!  input, standard output, and standard error) that may require
!  user customization.
!
!  Presented at the IFIP WG 2.5 International Workshop on
!  "Current Directions in Numerical Software and High Performance
!  Computing", 19 - 20 October 1995, Kyoto, Japan.
!
!  David Gay (dmg@bell-labs.com)
!  Eric Grosse (ehg@bell-labs.coM)
!  Bell Laboratories
!  700 Mountain Avenue
!  Murray Hill, New Jersey 07974-0636
!  USA
!
!  References:
!
!  David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray
!    Hill, NJ. submitted to ACM Transactions on Mathematical Software,
!    August 1996.
!
!  http://www.nsc.liu.se/~boein/ifip/kyoto/workshop-info/proceedings/einarsson/d1mach.html
!
! ---------------------------------------------------------------------

PRIVATE
PUBLIC :: R1MACH, D1MACH, I1MACH

CONTAINS

REAL FUNCTION R1MACH (I)
!
!   R1MACH can be used to obtain machine-dependent parameters for
!   single precision numbers.  The results for various values of I are:
!
!   R1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!   R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
!   R1MACH(3) = B**(-T), the smallest relative spacing.
!   R1MACH(4) = B**(1-T), the largest relative spacing.
!   R1MACH(5) = LOG10(B)
!
!   Assume single precision numbers are represented in the T-digit,
!   base-B form
!
!              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!   where 0 <= X(I) < B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX.
!
!   The values of B, T, EMIN and EMAX are provided in I1MACH as follows:
!   I1MACH(10) = B, the base.
!   I1MACH(11) = T, the number of base-B digits.
!   I1MACH(12) = EMIN, the smallest exponent E.
!   I1MACH(13) = EMAX, the largest exponent E.
!
!***REFERENCES
!
!  P. Fox, A. Hall and N. Schryer, Framework for a portable library,
!     ACM Transactions on Mathematical Software 4, 177-188 (1978).
!
!  David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray
!     Hill, NJ. submitted to ACM Transactions on Mathematical Software,
!     August 1996.
!
!***REVISION HISTORY  (YYMMDD)
!   790101  DATE WRITTEN
!   960329  Modified for Fortran 90 (BE after suggestions by Eric Grosse)
! --------------------------------------------------------------------

IMPLICIT NONE
INTEGER, INTENT(IN) :: I
REAL :: B, X = 1.0

B = RADIX(X)

SELECT CASE (I)
  CASE (1)
    R1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude.
  CASE (2)
    R1MACH = HUGE(X)               ! the largest magnitude.
  CASE (3)
    R1MACH = B**(-DIGITS(X))       ! the smallest relative spacing.
  CASE (4)
    R1MACH = B**(1-DIGITS(X))      ! the largest relative spacing.
  CASE (5)
    R1MACH = LOG10(B)
  CASE DEFAULT
    CALL ERRMSG('R1MACH - input argument out of bounds', .TRUE.)
END SELECT

RETURN
END FUNCTION R1MACH

DOUBLE PRECISION FUNCTION D1MACH (I)
!
!   D1MACH can be used to obtain machine-dependent parameters for
!   double precision numbers.  The results for various values of I are:
!
!   D1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!   D1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
!   D1MACH(3) = B**(-T), the smallest relative spacing.
!   D1MACH(4) = B**(1-T), the largest relative spacing.
!   D1MACH(5) = LOG10(B)
!
!   Assume double precision numbers are represented in the T-digit,
!   base-B form
!
!        sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!   where 0 <= X(I) < B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX.
!
!   The values of B, T, EMIN and EMAX are provided in I1MACH as follows:
!   I1MACH(10) = B, the base.
!   I1MACH(11) = T, the number of base-B digits.
!   I1MACH(12) = EMIN, the smallest exponent E.
!   I1MACH(13) = EMAX, the largest exponent E.
!
!***REFERENCES
!
!  P. Fox, A. Hall and N. Schryer, Framework for a portable library,
!     ACM Transactions on Mathematical Software 4, 177-188 (1978).
!
!  David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray
!    Hill, NJ. submitted to ACM Transactions on Mathematical Software,
!    August 1996.
!
!***REVISION HISTORY  (YYMMDD)
!   790101  DATE WRITTEN
!   960329  Modified for Fortran 90 (BE after suggestions by Eric Grosse)
! --------------------------------------------------------------------

IMPLICIT NONE
INTEGER, INTENT(IN) :: I
DOUBLE PRECISION :: B, X = 1.D0

B = RADIX(X)

SELECT CASE (I)
  CASE (1)
    D1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude.
  CASE (2)
    D1MACH = HUGE(X)               ! the largest magnitude.
  CASE (3)
    D1MACH = B**(-DIGITS(X))       ! the smallest relative spacing.
  CASE (4)
    D1MACH = B**(1-DIGITS(X))      ! the largest relative spacing.
  CASE (5)
    D1MACH = LOG10(B)
  CASE DEFAULT
    CALL ERRMSG('D1MACH - input arg out of bounds', .TRUE.)
END SELECT

RETURN
END FUNCTION D1MACH

INTEGER FUNCTION I1MACH (I)
!
!   I1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  The results for various values of I are:
!
!   I/O unit numbers (**MAY REQUIRE USER CUSTOMIZATION**):
!     I1MACH( 1) = the standard input unit.
!     I1MACH( 2) = the standard output unit.
!     I1MACH( 3) = the standard punch unit (obsolete, will cause error)
!     I1MACH( 4) = the standard error message unit.
!                  (the error message unit is usually 0 in UNIX systems)
!
!   Words:
!     I1MACH( 5) = the number of bits per integer storage unit.
!     I1MACH( 6) = the number of characters per integer storage unit.
!                  (obsolete, will cause an error)
!
!   Integers:
!     assume integers are represented in the S-digit, base-A form
!
!          sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
!
!     where 0 <= X(I) < A for I=0,...,S-1.
!
!     I1MACH( 7) = A, the base.
!     I1MACH( 8) = S, the number of base-A digits.
!     I1MACH( 9) = A**S - 1, the largest magnitude.
!
!   Floating-Point Numbers:
!     Assume floating-point numbers are represented in the T-digit,
!     base-B form
!                sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!     where 0 <= X(I) .LT. B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX.
!
!     I1MACH(10) = B, the base.
!
!   Single-Precision:
!     I1MACH(11) = T, the number of base-B digits.
!     I1MACH(12) = EMIN, the smallest exponent E.
!     I1MACH(13) = EMAX, the largest exponent E.
!
!   Double-Precision:
!     I1MACH(14) = T, the number of base-B digits.
!     I1MACH(15) = EMIN, the smallest exponent E.
!     I1MACH(16) = EMAX, the largest exponent E.
!
!***REFERENCES
!
!  P. Fox, A. Hall and N. Schryer, Framework for a portable library,
!     ACM Transactions on Mathematical Software 4, 177-188 (1978).
!
!  David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray
!    Hill, NJ. submitted to ACM Transactions on Mathematical Software,
!    August 1996.
!
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   960411  Modified for Fortran 90 (BE after suggestions by Eric Grosse)
! --------------------------------------------------------------------

IMPLICIT NONE
INTEGER, INTENT(IN) :: I
REAL :: X_single  = 1.0
DOUBLE PRECISION :: X_double = 1.D0

SELECT CASE (I)
  CASE (1)
    I1MACH = 5 ! Input unit
  CASE (2)
    I1MACH = 6 ! Output unit
  CASE (3)
    CALL ERRMSG('I1MACH: input arg = 3 is obsolete', .TRUE.)
  CASE (4)
    I1MACH = 0 ! Error message unit
  CASE (5)
    I1MACH = BIT_SIZE(I)
  CASE (6)
    CALL ERRMSG('I1MACH: input arg = 6 is obsolete', .TRUE.)
  CASE (7)
    I1MACH = RADIX(1)
  CASE (8)
    I1MACH = BIT_SIZE(I) - 1
  CASE (9)
    I1MACH = HUGE(1)
  CASE (10)
    I1MACH = RADIX(X_single)
  CASE (11)
    I1MACH = DIGITS(X_single)
  CASE (12)
    I1MACH = MINEXPONENT(X_single)
  CASE (13)
    I1MACH = MAXEXPONENT(X_single)
  CASE (14)
    I1MACH = DIGITS(X_double)
  CASE (15)
    I1MACH = MINEXPONENT(X_double)
  CASE (16)
    I1MACH = MAXEXPONENT(X_double)
  CASE DEFAULT
    CALL ERRMSG('I1MACH: input argument out of bounds', .TRUE.)
END SELECT

RETURN
END FUNCTION I1MACH

SUBROUTINE ERRMSG( MESSAG, FATAL )
!
!    Print a warning or error message to the default logical unit;
!    abort if error is fatal, otherwise return to calling program.
!    (user can insert call to symbolic dump routine; see below)
!    NOTE:  FATAL is an optional argument; omitting it simply
!           prints MESSAG with no limit on number of messages
!
IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
LOGICAL, OPTIONAL, INTENT(IN) :: FATAL
CHARACTER(LEN=*), INTENT(IN) :: MESSAG
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
INTEGER, PARAMETER :: MAXMSG = 100
INTEGER :: NUMMSG = 0
LOGICAL :: MSGLIM = .FALSE.
!-----------------------------------------------

IF (.NOT.PRESENT(FATAL)) THEN

   WRITE ( *, '(/,2A,/)' ) ' ****** ERROR *****  ', MESSAG
   RETURN

END IF

IF (FATAL) THEN

   WRITE ( *, '(/,2A,/)' ) ' ****** ERROR *****  ', MESSAG

!     (insert call to symbolic dump routine here if desired)

   STOP

END IF

NUMMSG = NUMMSG + 1
IF (MSGLIM) RETURN

IF (NUMMSG <= MAXMSG) THEN

   WRITE ( *, '(/,2A,/)' ) ' ****** WARNING *****  ', MESSAG

ELSE

   MSGLIM = .TRUE.
   WRITE ( *, '(//,A,//)' ) &
' ****** TOO MANY WARNING MESSAGES -- will no longer be printed *******'

END IF

RETURN
END SUBROUTINE ERRMSG

END MODULE RDI1MACH_f90

max_stars_repo_name: GEOS-ESM/AeroApps

max_issues_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps