    MODULE biomath_strings_mod
! Contains procedures (methods) related to string operations
! .. Use Statements ..
      USE biomath_constants_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: lower_case_char, lower_case_string, qlex, &
        upper_case_char, upper_case_string
! ..
! .. Parameters ..
      CHARACTER (26), PARAMETER :: locase = 'abcdefghijklmnopqrstuvwxyz'
      CHARACTER (26), PARAMETER :: upcase = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
! ..
    CONTAINS

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

      FUNCTION lower_case_char(chr)
!!!-------------------------------------------------------------------
!!!
!!! NAME: translate one character to LOWER case
!!!
!!! DESCRIPTION:
!!!
!!! If CHR is an UPPER case letter 'A..Z', returns the corresponding
!!! lower case letter .
!!! If CHR is not an upper case letter, then returns CHR.
!!!
!!! ARGUMENT:
!!!
!!! CHR --> Character to be translated to LOWER case.
!!!                              CHARACTER*1 CHR
!!!
!!!-------------------------------------------------------------------
! .. Function Return Value ..
        CHARACTER (1) :: lower_case_char
! ..
! .. Scalar Arguments ..
        CHARACTER (1), INTENT (IN) :: chr
! ..
! .. Local Scalars ..
        INTEGER :: ix
        LOGICAL :: qnotuc
! ..
! .. Intrinsic Functions ..
        INTRINSIC INDEX, LGT, LLT
! ..
        qnotuc = (LLT(chr,'A') .OR. LGT(chr,'Z'))

        IF (qnotuc) THEN
! chr is not an UPPER case letter

          lower_case_char = chr

          RETURN

        END IF

        ix = INDEX(upcase,chr)

        IF (ix<=0) THEN
          lower_case_char = chr
        ELSE
! Convert UPPER case to LOWER case
          lower_case_char = locase(ix:ix)
        END IF

        RETURN

      END FUNCTION lower_case_char

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

      FUNCTION upper_case_char(chr)
!!!-------------------------------------------------------------------
!!!
!!! NAME: translate one character to UPPER case
!!!
!!! DESCRIPTION:
!!!
!!! If CHR is a lower case letter 'a..z' returns the  corresponding
!!! UPPER case letter.
!!! If CHR is not a lower case letter, then returns CHR.
!!!
!!! ARGUMENT:
!!!
!!! CHR --> Character to be translated to UPPER case.
!!!                              CHARACTER*1 CHR
!!!
!!!-------------------------------------------------------------------
! .. Function Return Value ..
        CHARACTER (1) :: upper_case_char
! ..
! .. Scalar Arguments ..
        CHARACTER (1), INTENT (IN) :: chr
! ..
! .. Local Scalars ..
        INTEGER :: ix
        LOGICAL :: qnotuc
! ..
! .. Intrinsic Functions ..
        INTRINSIC INDEX, LGT, LLT
! ..
        qnotuc = (LLT(chr,'a') .OR. LGT(chr,'z'))

        IF (qnotuc) THEN
! chr is not a LOWER case letter

          upper_case_char = chr

          RETURN

        END IF

        ix = INDEX(locase,chr)

        IF (ix<=0) THEN
          upper_case_char = chr
        ELSE
! Convert LOWER case to UPPER case
          upper_case_char = upcase(ix:ix)
        END IF

        RETURN

      END FUNCTION upper_case_char

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

      SUBROUTINE lower_case_string(str)
!!!-------------------------------------------------------------------
!!!
!!! NAME: LOWer CASE a whole STRING
!!!
!!! DESCRIPTION:
!!!
!!! For each CHR in STR, if CHR is an upper case letter 'A..Z' then it
!!! is replaced by the corresponding lower case letter .
!!! If CHR is not an upper case letter, then nothing happens to CHR.
!!!
!!! ARGUMENT:
!!!
!!! STR <-> String to be translated to lower case.
!!!                             CHARACTER*(*) STR
!!!
!!!-------------------------------------------------------------------
! .. Scalar Arguments ..
        CHARACTER (*), INTENT (INOUT) :: str
! ..
! .. Local Scalars ..
        INTEGER :: ix, j
        LOGICAL :: qnotuc
        CHARACTER (1) :: chr
! ..
! .. Intrinsic Functions ..
        INTRINSIC INDEX, LEN_TRIM, LGT, LLT
! ..
        DO j = 1, LEN_TRIM(str)

          chr = str(j:j)

          qnotuc = (LLT(chr,'A') .OR. LGT(chr,'Z'))

          IF (qnotuc) CYCLE

          ix = INDEX(upcase,chr)

          IF (ix<=0) CYCLE

          str(j:j) = locase(ix:ix)

        END DO

        RETURN

      END SUBROUTINE lower_case_string

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

      SUBROUTINE upper_case_string(str)
!!!-------------------------------------------------------------------
!!!
!!! NAME: UPper CASE a whole STRING
!!!
!!! DESCRIPTION:
!!!
!!! For each CHR in STR, if CHR is an LOWER case letter 'a..z' then it
!!! is replaced by the corresponding UPPER case letter .
!!! If CHR is not an lower case letter, then nothing happens to CHR.
!!!
!!! ARGUMENT:
!!!
!!! STR <-> String to be translated to upper case.
!!!                             CHARACTER*(*) STR
!!!
!!!-------------------------------------------------------------------
! .. Scalar Arguments ..
        CHARACTER (*), INTENT (INOUT) :: str
! ..
! .. Local Scalars ..
        INTEGER :: ix, j
        LOGICAL :: qnotuc
        CHARACTER (1) :: chr
! ..
! .. Intrinsic Functions ..
        INTRINSIC INDEX, LEN_TRIM, LGT, LLT
! ..
        DO j = 1, LEN_TRIM(str)

          chr = str(j:j)

          qnotuc = (LLT(chr,'a') .OR. LGT(chr,'z'))

          IF (qnotuc) CYCLE

          ix = INDEX(locase,chr)

          IF (ix<=0) CYCLE

          str(j:j) = upcase(ix:ix)

        END DO

        RETURN

      END SUBROUTINE upper_case_string

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

      FUNCTION qlex(string,qstart,curtyp,cval,lcval,ival,dval,indov)
!------------------------------------------------------------------------
!     Name: Lexical Analyser
!     Description:
!         QLEX is a lexical analyser intended for command languages.
!     QLEX recognizes numbers, names, quoted character strings,
!     delimiters, operators, and two categories of probable error.
!     Ignoring probable errors, the blank character is the universal
!     separator of tokens, and blanks are never part of tokens except
!     for quoted strings.  In particular, a blank token is returned
!     only when it occurs within quotes.  Number and name tokens may be
!     terminated by being followed by a delimiter or operator (or a
!     blank).
!         Complete details on the types of tokens and the process of
!     decomposition are given below in the section titled Details.
!     Use:
!         Each call to QLEX causes it to begin searching for a token
!     starting at the position after the end of the last token returned
!     (if any).  If it finds another token, it will return the value
!     .TRUE., otherwise it will return the value .FALSE.  If QLEX
!     returns .FALSE. then all output variables (except QSTART) are
!     undefined.
!         QSTART is set to .TRUE. on a call to QLEX to indicate that
!     it should begin at the beginning of the string in locating the
!     next token.  Successive calls for more tokens in the same string
!     should ensure that QSTART is .FALSE. on entry to QLEX.  To make
!     this easy, QLEX always changes QSTART to .FALSE. before returning.
!         Since QLEX remembers its position and other things between
!     calls, it should be used only on one string at a time.  Calls
!     which alternate between different strings (with QSTART .FALSE.)
!     will produce unpredictable results.
!     Return Value:
!     QLEX <- .TRUE. if a token has been identified and returned,
!             .FALSE. if there are no tokens remaining in STRING.
!             LOGICAL QLEX
!     Arguments:
!     STRING -> The character string to be decomposed into lexical
!               tokens.
!               CHARACTER*(*) STRING
!     QSTART <-> On input, QSTART should be set to .TRUE. to indicate
!                that the first token in STRING is to be found.  A
!                value of .FALSE. indicates that the token following
!                the one found in the previous call should be returned.
!                NOTE: An erroneous value of .FALSE. can lead to
!                unpredictable results.
!                LOGICAL QSTART
!     CURTYP <- Defined only if QLEX is .TRUE.  The types are
!                 IN -- INteger
!                 RL -- ReaL
!                 ID -- alphanumeric name or IDentifier
!                 QS -- Quoted character String
!                 DL -- DeLimiter
!                 OP -- string of OPerator symbols
!                 OS -- Other String
!                       A string of characters recognized by QLEX but
!                       not fitting into the above categories.
!                       (This is usually an error.)
!                 UC -- Unrecognized Characters
!                       A string of characters not recognized by QLEX,
!                       i.e., characters that do not occur in some
!                       definition above.
!                       (This is usually an error.)
!             CHARACTER*2 CURTYP
!     CVAL <- Defined only if QLEX is .TRUE.  The character value of
!             the token found.  The token will be left adjusted.
!             For safety, CVAL should be as long as STRING.
!             CHARACTER*(*) CVAL
!     LCVAL <- Defined only if QLEX is .TRUE.  The length of the
!              token returned in CVAL.
!              INTEGER LCVAL
!     IVAL <- Defined only if QLEX is .TRUE. and CURTYP.EQ.'IN'
!             (Integer) or CURTYP.EQ.'RL' (Real).
!             The integer value of the token.
!             INTEGER IVAL
!     DVAL <- Defined only if QLEX is .TRUE. and CURTYP.EQ.'IN' or
!             CURTYP.EQ.'RL' (Integer or Real).  The real value of
!             the token stored in a double precision number.
!             DOUBLE PRECISION DVAL
!     INDOV <- Overflow indicator. If CURTYP.EQ.'IN' or CURTYP.EQ.'RL'
!              indicated if the value input is too large to store.
!              The indicators are:
!                  0 -- No overflow (IVAL and DVAL defined)
!                  1 -- INTEGER overflow (DVAL defined)
!                  2 -- REAL overflow (No values defined)
!              INTEGER INDOV
!     Details:
!         Syntax of the tokens is given in extended Backus-Naur form.
!     Square braces, [...], indicate that the contents can appear zero
!     or one times.  The braces, (*...*), indicate that the contents
!     can occur zero or more times.  The construct <BLANK> indicates the
!     blank character, ' '; <CHARACTER> is any legal character (this
!     varies from machine to machine); <SLASH> is the '/' character
!     which is named because it is used as the OR symbol in the
!     description language.
!     -- Integer or Real Strings --
!         Both types can begin with a sign or a digit.  The sign can
!     be separated from the following characters by blanks.  The fol-
!     lowing characters can be only digits for an integer.  A real
!     can begin with a decimal point, '.', followed by a fraction.
!     A real can have an optional exponential part.  This has the form
!     E (or D) followed by a number.
!         Both types of tokens are terminated by being followed by a
!     blank character, an operator character, a delimiter, or a
!     character not defined to QLEX (the latter is usually an error).
!         NOTE: Spaces between the sign and the first character of
!     the remainder of the number are removed in CVAL.
!         <SIGN> ::= +/-
!         <DIGIT> ::= 0/.../9
!         <DIGITST> ::= <DIGIT> (*<DIGIT>*)
!         <INTEGER> ::= [<SIGN>] <DIGITST>
!         <REAL PART> ::= [<SIGN>] [<DIGITST>].<DIGITST> /
!                         [<SIGN>] <DIGITST>.[<DIGITST>]
!         <EXP IND> ::= d/D/e/E
!         <EXP PART> ::= <EXP IND> [<SIGN>] <DIGITST>
!         <REAL> ::= <REAL PART> [<EXP PART>]
!     -- Alphanumeric Name or Identifier --
!         The token must begin with a letter.  Succeeding characters
!     can be letters, digits, or one of the characters
!     '$', '.', or '_' (underscore character).
!         The token is terminated by being followed by a
!     blank character, an operator character, a delimiter, or a
!     character not defined to QLEX (the latter is usually an error).
!         <LETTER> ::= a/.../z/A/.../Z
!         <OTHER ALPHAS> ::= $/./_
!         <EXTENDED ALPHA> ::= <LETTER>/<DIGIT>/<OTHER ALPHAS>
!         <IDENTIFIER> ::= <LETTER>(*<EXTENDED ALPHA>*)
!     -- Quoted String --
!         A quoted string is surrounded by the same quote delimiters,
!     which can be either a single or double quote (' or ").  The
!     appearance of the quote delimiter within a string is indicated
!     by its doubling.  Thus, the string 'don''t' is recognized as
!     the word "don't".  Any characters whatsoever may be in a quoted
!     string, even characters not recognized by QLEX.
!         The quoted string returned by QLEX in CVAL does not include
!     the surrounding single or double quotes. Doubled occurrences of
!     the quoting character within the string are replaced by a single
!     occurrence within CVAL.
!         <QUOTED STRING> ::= '<CHARACTER>(*<CHARACTER>*)' /
!                             "<CHARACTER>(*<CHARACTER>*)"
!     -- Delimiter --
!         A delimiter is a single character from the set specified.
!         <DELIMITER> ::= , / ( / ) / { / } / : / ;
!         In ASCII, square brackets '[' and ']' are added to the set
!     of delimiter characters. These characters do not exist in EBCDIC.
!     -- String of Operators --
!         A string of operators is any contiguous string of operator
!     characters and is terminated by any character that is not an
!     operator.
!         <OPERATOR CHARACTER> ::= + / - / * / <SLASH> / < / > / =
!         <STRING OF OPERATORS>::= <OPERATOR CHARACTER>
!                                       (*<OPERATOR CHARACTER>*)
!     -- String of Recognized Characters --
!         This is a string of characters that are included in some
!     definition above but such that the string does not fall into
!     any of the above defined categories.  The string is terminated by
!     being followed by a blank or an unrecognized character.
!         This category is usually a mistake caused by the ommission of
!     a blank, ending quote, or some other error.
!     -- String of Unrecognized Characters --
!         This is a string of characters that are not included in some
!     definition above.  The string is terminated by being followed by
!     a recognized character.
!     Notes:
!         A plus or minus character (+ or -) is a unary
!     sign if the current call to QLEX has QSTART = .TRUE., or if the
!     preceding token was an operator string, or if the preceding token
!     was one of the delimiters, or if the next character is a digit.
!     In all other cases, the character is considered to be
!     a binary operator.
!----------------------------------------------------------------------
!****
!     BLANK   --  Constant used for comparison.
!****
!****
!     The twelve non-digit classes of characters. Each digit 0-9
!     has itself for a value.
!     CPER    --  The class consisting of the period, '.'
!     CPLU    --  The class consisting of the plus, '+'
!     CMIN    --  The class consisting of the minus, '-'
!     CEXP    --  The class of exponent indicators,
!                 'E', 'e', 'D', and 'd'
!     CALP    --  The class of alphabetic characters not contained
!                 in CEXP
!     COAL    --  The class of other alphabetic characters not
!                 contained in CPLU or CMIN
!     CBLA    --  The class consisting of the space, ' '
!     CDLM    --  The class consisting of the delimiter characters.
!     CQUO    --  The class consisting of the single and double
!                 quotes
!     COPR    --  The class consisting of the operator characters
!     COTH    --  The class consisting of recognized characters
!                 not fitting in one of the above classes
!     CUNR    --  The class of unrecognizable characters strings
!****
!****
!     The set of states of the finite state machine.
!     SNLL    --  This is not a state of the finite state machine.
!                 This is a dummy entry, used when no state transition
!                 will occur.
!     STRT    --  start state; terminated when non-blank encountered.
!     SSGN    --  sign state; a + or - has been encounterd.
!     SDIG    --  digit state; a digit has been encounterd.
!     SPER    --  period state; a . (decimal point) has been encounterd.
!     SFRC    --  fraction state; a digit after the decimal point has
!                 been encounterd.
!     SEEX    --  exponent indicator state; one of the characters
!                 'E', 'e', 'D', or 'd' has been encountered.
!     SSEX    --  exponent sign state; a + or - has been encounterd
!                 after an exponent indicator.
!     SDEX    --  exponent digit state; a digit of the exponent
!                 has been encountered.
!     SID     --  identifier state; an alphabetic character, digit,
!                 or other alphabetic character has been encountered.
!                 (Digits and other alphabetic characters are valid only
!                 if they are not the first character of the token.)
!     SDLM    --  delimiter state; a delimiter character has been
!                 encountered.
!     SSTR    --  string state; a single or double quote has been
!                 encountered.
!     SOPR    --  operator state; an operator character has been
!                 encountered.
!     SOTH    --  other string state; a recognized character not
!                 fitting one of the above states has been encountered.
!     SUNR    --  unrecognizalbe character state; an unrecognizable
!                 character has been encountered.
!****
!****
!     The set of actions to be performed, depending on the state
!     of the finite state machine and the class of the current
!     character.
!     AAIN    --  accumulate integer part of number and string;
!                 set CURTYP = integer
!     AAFR    --  accumulate fractional part of number and string;
!                 set CURTYP = real
!     AAEX    --  accumulate exponent and string;
!     AAST    --  accumulate string;
!     AASR    --  accumulate string;
!                 set CURTYP = real
!     AASO    --  accumulate string;
!                 set CURTYP = other string
!     AAIP    --  accumulate string;
!                 set CURTYP = integer; set SIGN = plus
!     AAIM    --  accumulate string;
!                 set CURTYP = integer; set SIGN = minus
!     AAEP    --  accumulate string;
!                 set ESIGN = positive
!     AAEM    --  accumulate string;
!                 set ESIGN = MINUS
!     AAID    --  accumulate string;
!                 set CURTYP = identifier
!     AANL    --  accumulate nothing;
!                 take no action
!     AASP    --  accumulate string;
!                 set CURTYP = operator string
!     AASU    --  accumulate string;
!                 set CURTYP = unrecognizable character string
!     ATQS    --  accumulate nothing;
!                 set CURTYP = quoted string
!     ACQS    --  check for end of quoted string;
!                 if end of quoted string, return quoted string
!                 else accumulate string
!     ARIN    --  return integer;
!     ARRL    --  return real number;
!     ARID    --  return identifier;
!     ARDL    --  return delimiter;
!     AROP    --  return operator string;
!     AROS    --  return other string;
!     ARUC    --  return unrecognizable character string;
!     ARSO    --  if previous character is blank,
!                 change sign to operator string and return;
!                 else accumulate string and set CURTYP = other string;
!     ARPO    --  if previous character is blank,
!                 change period to other character string;
!****
!****
!     The above are the various token types that may be returned.
!****
!****
!     CURCHR  --  The character currently being processed.
!     PRVCHR  --  The previous character processed.
!     NXTCHR  --  The next character to be processed.
!     STRDLM  --  The delimiter of the current string, if processing
!                 a quoted string.
!     PRVTYP  --  The type of the token returned in any previous call
!                 to this routine.
!****
!****
!     POSN    --  The position in the input string of the character
!                 currently being processed.
!     INTPT   --  The integer part of the number currently being
!                 processed.
!     EXPPT   --  The exponent of the number currently being
!                 processed.
!     SIGN    --  The sign of the integer or real part of the
!                 number currently being processed.
!     ESIGN   --  The sign of the exponent of the number currently
!                 being processed.
!     LENSTR  --  The length of the string being parsed.
!     CHRTYP  --  The type of the current character.
!     NXCTYP  --  The type of the next character.
!     CLASS   --  The class of the current character.
!     STATE   --  The current state of the finite state machine.
!     ACTION  --  Action to be performed.
!     POWER   --  Power of fraction part of current number.
!     EPOW    --  Exponent (absalute value) of fraction part of
!                 current number.
!****
!****
!     NVALUE  --  Dummy argument of statement function ACCUM.
!     ZDIGIT  --  Dummy argument of statement function ACCUM.
!     ACCUM   --  Statement function.
!****
!****
!     IMAX    --  MACHINE CONSTANT, maximum integer value.
!     DMAX    --  MACHINE CONSTANT, maximum double precision value.
!     RMAX    --  MACHINE CONSTANT, maximum real value.
!****
!****
!     Other variables.
!****
!****
!     POWVEC  --  A vector of powers of 10. (1e-1, 1e-2,..., 1e-20)
!                 This is used for an accurate and fast value.
!****
! .. Function Return Value ..
        LOGICAL :: qlex
! ..
! .. Parameters ..
        REAL (dpkind), PARAMETER :: dmax = HUGE(1.0E0_dpkind)
        REAL (dpkind), PARAMETER :: dmax10 = dmax/10.0E0_dpkind
        REAL (dpkind), PARAMETER :: rmax = HUGE(1.0_dpkind)
        REAL (dpkind), PARAMETER :: drmax = rmax
        REAL (dpkind), PARAMETER :: powvec(20) = (/ 1.0E-1_dpkind, &
          1.0E-2_dpkind, 1.0E-3_dpkind, 1.0E-4_dpkind, 1.0E-5_dpkind, &
          1.0E-6_dpkind, 1.0E-7_dpkind, 1.0E-8_dpkind, 1.0E-9_dpkind, &
          1.0E-10_dpkind, 1.0E-11_dpkind, 1.0E-12_dpkind, 1.0E-13_dpkind, &
          1.0E-14_dpkind, 1.0E-15_dpkind, 1.0E-16_dpkind, 1.0E-17_dpkind, &
          1.0E-18_dpkind, 1.0E-19_dpkind, 1.0E-20_dpkind/)
        INTEGER, PARAMETER :: aaem = 10, aaep = 9, aaex = 3, aafr = 2, &
          aaid = 11, aaim = 8, aain = 1, aaip = 7, aanl = 12, aaso = 6, &
          aasp = 13, aasr = 5, aast = 4, aasu = 14, acqs = 16, ardl = 20, &
          arid = 19, arin = 17, arop = 21, aros = 22, arpo = 25, &
          arrl = 18, arso = 24, aruc = 23, atqs = 15, calp = 14, &
          cbla = 16, cdlm = 17, cexp = 13, cmin = 12, coal = 15, &
          copr = 19, coth = 20, cper = 10, cplu = 11, cquo = 18, &
          cunr = 21
        INTEGER, PARAMETER :: imax = HUGE(1)
        INTEGER, PARAMETER :: sdex = 8, sdig = 3, sdlm = 10, seex = 6, &
          sfrc = 5, sid = 9, snll = 0, sopr = 12, soth = 13, sper = 4, &
          ssex = 7, ssgn = 2, sstr = 11, strt = 1, sunr = 14
        CHARACTER (1), PARAMETER :: blank = ' '
        CHARACTER (2), PARAMETER :: typdl = 'DL', typid = 'ID', &
          typin = 'IN', typop = 'OP', typos = 'OS', typqs = 'QS', &
          typrl = 'RL', typuc = 'UC'
        REAL (dpkind), PARAMETER :: dimax = imax
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: dval
        INTEGER, INTENT (OUT) :: indov, ival, lcval
        LOGICAL, INTENT (INOUT) :: qstart
        CHARACTER (2), INTENT (OUT) :: curtyp
        CHARACTER (*), INTENT (OUT) :: cval
        CHARACTER (*), INTENT (IN) :: string
! ..
! .. Local Scalars ..
        REAL (dpkind) :: exppt, fracpt, intpt, power
        INTEGER :: action, chrtyp, class, epow, esign, i, j, nxctyp, &
          sign, state
        INTEGER, SAVE :: lenstr, posn
        LOGICAL :: qcopy
        CHARACTER (1) :: curchr, nxtchr, strdlm
        CHARACTER (1), SAVE :: prvchr
        CHARACTER (2), SAVE :: prvtyp
! ..
! .. Intrinsic Functions ..
        INTRINSIC HUGE, LEN_TRIM, REAL
! ..
!***
!     If QSTART is TRUE then initialize one time information.
!****
        IF (qstart) THEN
          posn = 1
          prvchr = ' '
          prvtyp = '  '
          lenstr = LEN_TRIM(string) + 1
        END IF
!****
!     Initalize variables for current TOKEN.
!****
        cval = ' '
        lcval = 0

        ival = 0
        dval = zero

        qstart = .FALSE.
        qlex = .FALSE.

! The current character
        curchr = string(posn:posn)

! The character type
        chrtyp = ncqlex(curchr)

        indov = 0

        intpt = zero
        fracpt = zero

        exppt = zero
        epow = 0

        sign = 1
        esign = 1

        state = 1

!-----------------------------------------------------------------------
!     Read one character at a tine, until end of token.
!-----------------------------------------------------------------------

        DO
          IF (posn>lenstr) EXIT

! DMS    If the caracter is not going to be saved to the buffer cval,
!        set qcopy to .FALSE. (states AANL and ATQS)

          qcopy = .TRUE.

          IF (chrtyp<=9) THEN
! A digit (0..9) was read)
            class = 1
          ELSE
! Anything else other than digit
            class = chrtyp - 8
          END IF

          action = get_action(class,state)

          state = next_state(class,state)

! Get NEXT character
          IF (posn<lenstr) THEN
            nxtchr = string(posn+1:posn+1)
          ELSE
            nxtchr = ' '
          END IF

! Get next caharacter's type
          nxctyp = ncqlex(nxtchr)

          IF ((chrtyp==cplu) .OR. (chrtyp==cmin)) THEN
            IF (prvchr==' ') THEN
              IF (class==(cplu-8)) THEN
                action = aaip
              ELSE
                action = aaim
              END IF
            END IF
          END IF

!-----------------------------------------------------------------------
!     Perform action specified in action table.
!-----------------------------------------------------------------------

          SELECT CASE (action)

          CASE (aain)
!****
!     AAIN    --  accumulate integer part of number and string;
!                 set CURTYP = integer
!****
            intpt = accum(intpt,chrtyp)

            curtyp = typin

          CASE (aafr)
!****
!     AAFR    --  accumulate fractional part of number and string;
!                 set CURTYP = real
!****
            epow = epow + 1

            IF (epow<=20) THEN
              power = powvec(epow)
            ELSE
              power = power*0.1E0_dpkind
            END IF

            fracpt = fracpt + (REAL(chrtyp,kind=dpkind)*power)

            curtyp = typrl

          CASE (aaex)
!****
!     AAEX    --  accumulate exponent and string;
!****
            exppt = accum(exppt,chrtyp)

          CASE (aast)
!****
!     AAST    --  accumulate string;
!****

          CASE (aasr)
!****
!     AASR    --  accumulate string;
!                 set CURTYP = real
!****
            curtyp = typrl

          CASE (aaso)
!****
!     AASO    --  accumulate string;
!                 set CURTYP = other string
!****
            curtyp = typos

          CASE (aaip)
!****
!     AAIP    --  accumulate string;
!                 set CURTYP = integer; set SIGN = plus
!****
            curtyp = typin
            sign = 1

          CASE (aaim)
!****
!     AAIM    --  accumulate string;
!                 set CURTYP = integer; set SIGN = minus
!****
            curtyp = typin
            sign = -1

          CASE (aaep)
!****
!     AAEP    --  accumulate string;
!                 set ESIGN = positive
!****
            esign = 1

          CASE (aaem)
!****
!     AAEM    --  accumulate string;
!                 set ESIGN = MINUS
!****
            esign = -1

          CASE (aaid)
!****
!     AAID    --  accumulate string;
!                 set CURTYP = identifier
!****
            curtyp = typid

          CASE (aanl)
!****
!     AANL    --  accumulate nothing;
!                 take no action
!****
            qcopy = .FALSE.

          CASE (aasp)
!****
!     AASP    --  accumulate string;
!                 set CURTYP = operator string
!****
            curtyp = typop

          CASE (aasu)
!****
!     AASU    --  accumulate string;
!                 set CURTYP = unrecognizable character string
!****
            curtyp = typuc

          CASE (atqs)
!****
!     ATQS    --  accumulate nothing;
!                 set CURTYP = quoted string
!****
            strdlm = curchr
            curtyp = typqs
            qcopy = .FALSE.

          CASE (acqs)
!****
!     ACQS    --  check for end of quoted string;
!                 if end of quoted string, return quoted string
!                 else accumulate string
!****
            IF (curchr==strdlm) THEN
              IF (string(posn+1:posn+1)==strdlm) THEN
                posn = posn + 1
              ELSE
                posn = posn + 1
                prvtyp = curtyp
                qlex = .TRUE.

                RETURN
              END IF
            END IF

          CASE (arin)
!****
!     ARIN    --  return integer;
!****
            CALL set_numeric_values

            RETURN

          CASE (arrl)
!****
!     ARRL    --  return real number;
!****
            CALL set_numeric_values

            RETURN

          CASE (arid)
!****
!     ARID    --  return identifier;
!****
            prvtyp = curtyp
            qlex = .TRUE.

            RETURN

          CASE (ardl)
!****
!     ARDL    --  return delimiter;
!****
            lcval = lcval + 1
            cval(lcval:lcval) = curchr
            curtyp = typdl
            posn = posn + 1
            prvtyp = curtyp
            qlex = .TRUE.

            RETURN

          CASE (arop)
!****
!     AROP    --  return operator string;
!****
            prvtyp = curtyp
            qlex = .TRUE.

            RETURN

          CASE (aros)
!****
!     AROS    --  return other string;
!****
            prvtyp = curtyp
            qlex = .TRUE.

            RETURN

          CASE (aruc)
!****
!     ARUC    --  return unrecognizable character string;
!****
            prvtyp = curtyp
            qlex = .TRUE.

            RETURN

          CASE (arso)
!****
!     ARSO    --  if previous character is blank,
!                 change sign to operator string and return;
!                 else accumulate string and set CURTYP = other string;
!****
            IF (prvchr==blank) THEN
              posn = posn - 1
              curtyp = typop
              prvtyp = curtyp
              qlex = .TRUE.
              RETURN

            ELSE
              curtyp = typos
            END IF

          CASE (arpo)
!****
!     ARPO    --  if previous character is blank,
!                 change period to other character string and return;
!                 else return real;
!****
            IF (cval(1:1)=='.') THEN
              curtyp = typos
              prvtyp = curtyp
              qlex = .TRUE.

              RETURN

            ELSE
              CALL set_numeric_values

              RETURN

            END IF

          END SELECT

          IF (qcopy) THEN
            lcval = lcval + 1
            cval(lcval:lcval) = curchr
          END IF

!        If this is the first character encountered and it is a plus,
!        '+' or minus '-' and the previous character was a separator
!        or the next character is a digit then set the SIGN state.

          IF ((chrtyp==cplu) .OR. (chrtyp==cmin)) THEN

            IF (prvchr==' ') THEN
              state = ssgn
            END IF
          END IF

          prvchr = curchr
          curchr = nxtchr
          chrtyp = nxctyp

          posn = posn + 1

        END DO

        IF (curtyp==typqs) THEN
          curtyp = typos
          prvtyp = curtyp
          qlex = .TRUE.
        END IF

        IF (state==ssgn) THEN
          curtyp = typop
          prvtyp = curtyp
          qlex = .TRUE.
        END IF
!     ..
!     .. Return Statement ..
        RETURN

      CONTAINS

!.....................................................................

        FUNCTION accum(nvalue,zdigit)
!     This function is used to accumulate the integer part
!     or the exponent of the number currently being processed.
! ..
! .. Function Return Value ..
          REAL (dpkind) :: accum
! ..
! .. Parameters ..
          REAL (dpkind), PARAMETER :: ten = 10.0_dpkind
! ..
! .. Scalar Arguments ..
          REAL (dpkind), INTENT (IN) :: nvalue
          INTEGER, INTENT (IN) :: zdigit
! ..
          accum = (ten*nvalue) + zdigit

        END FUNCTION accum

!.....................................................................

        FUNCTION get_action(class,state)
! STRT - start state
! SSGN - sign state
! SDIG - digit state
! SPER - period state
! SFRC - fraction state
! SEEX - exponent indicator state
! SSEX - exponent sign state
! SDEX - exponent digit state
! SID  - identifier state
! SDLM - delimiter state
! SSTR - string state
! SOPR - operator state
! SOTH - other character state
! SUNR - unrecognizable character state
! ..
! .. Function Return Value ..
          INTEGER :: get_action
! ..
! .. Parameters ..
          INTEGER, PARAMETER :: actntb(13,14) = RESHAPE((/aain,aasr,aasp, &
            aasp,aaid,aaid,aaso,aanl,ardl,atqs,aasp,aaso,aasu,aain,aasr, &
            arso,arso,arso,arso,arso,aanl,arso,arso,arso,arso,arso,aain, &
            aasr,arin,arin,aasr,aaso,aaso,arin,arin,aaso,arin,aaso,arin, &
            aafr,aaso,arrl,arrl,aast,aaso,aaso,arpo,arrl,aaso,arrl,aaso, &
            arrl,aafr,aaso,arrl,arrl,aasr,aaso,aaso,arrl,arrl,aaso,arrl, &
            aaso,arrl,aaex,aaso,aaep,aaem,aaso,aaso,aaso,aros,aaso,aaso, &
            aaso,aaso,aros,aaex,aaso,aaso,aaso,aaso,aaso,aaso,aros,aaso, &
            aaso,aaso,aaso,aros,aaex,aaso,arrl,arrl,aaso,aaso,aaso,arrl, &
            arrl,aaso,arrl,aaso,arrl,aast,aast,arid,arid,aast,aast,aast, &
            arid,arid,aaso,arid,aaso,arid,aanl,aanl,aanl,aanl,aanl,aanl, &
            aanl,aanl,aanl,aanl,aanl,aanl,aanl,aast,aast,aast,aast,aast, &
            aast,aast,aast,aast,acqs,aast,aast,aast,arop,arop,aast,aast, &
            arop,arop,arop,arop,arop,arop,aast,arop,arop,aast,aast,aast, &
            aast,aast,aast,aast,aros,aast,aast,aast,aast,aros,aruc,aruc, &
            aruc,aruc,aruc,aruc,aruc,aruc,aruc,aruc,aruc,aruc,aast/), &
            shape=(/13,14/),order=(/1,2/))
! ..
! .. Scalar Arguments ..
          INTEGER, INTENT (IN) :: class, state
! ..
! .. Intrinsic Functions ..
          INTRINSIC RESHAPE
! ..
          get_action = actntb(class,state)

          RETURN

        END FUNCTION get_action

!.....................................................................

        FUNCTION ncqlex(char)
!****
!     This function looks up the class of a given character
!     in the CHRSET array.
!****
! 8 uprintable characters
! 8 uprintable characters
! 8 uprintable characters
! 8 uprintable characters
!            BLANK  !     "     #    $     %     &     '
!            (     )     *     +     ,     -     .     /
!            0     1      2     3     4     5     6     7
!             8     9     :     ;     <     =     >     ?
!             @     A     B     C     D     E     F     G
!             H     I     J     K     L     M     N     O
!             P     Q     R     S     T     U     V     W
!             X     Y     Z     [     \     ]     ^     _
!             `     a     b     c     d     e     f     g
!             h     i     j     k     l     m     n     o
!             p     q     r     s     t     u     v     w
! ..
! .. Function Return Value ..
          INTEGER :: ncqlex
! ..
! .. Parameters ..
          INTEGER, PARAMETER :: chrset(0:127) = (/ cunr, cunr, cunr, &
            cunr, cunr, cunr, cunr, cunr, cunr, cunr, cunr, cunr, cunr, &
            cunr, cunr, cunr, cunr, cunr, cunr, cunr, cunr, cunr, cunr, &
            cunr, cunr, cunr, cunr, cunr, cunr, cunr, cunr, cunr, cbla, &
            cunr, cquo, cunr, coal, cunr, cunr, cquo, cdlm, cdlm, copr, &
            cplu, cdlm, cmin, cper, copr, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, &
            cdlm, cdlm, copr, copr, copr, cunr, cunr, calp, calp, calp, &
            cexp, cexp, calp, calp, calp, calp, calp, calp, calp, calp, &
            calp, calp, calp, calp, calp, calp, calp, calp, calp, calp, &
            calp, calp, calp, cdlm, cunr, cdlm, cunr, coal, cunr, calp, &
            calp, calp, cexp, cexp, calp, calp, calp, calp, calp, calp, &
            calp, calp, calp, calp, calp, calp, calp, calp, calp, calp, &
            calp, calp, calp, calp, calp, cdlm, cunr, cdlm, cunr, cunr/)
! ..
! .. Scalar Arguments ..
          CHARACTER (1), INTENT (IN) :: char
! ..
! .. Intrinsic Functions ..
          INTRINSIC IACHAR
! ..
!             x     y     z     {     |     }     ~     DEL
          ncqlex = chrset(IACHAR(char))

          RETURN
        END FUNCTION ncqlex

!.....................................................................

        FUNCTION next_state(class,state)
!****
!     Transition Table.
!     Row indices are the character classes
!     Column index is the current state
!     Table entry is next state given current state and class of
!     the next character seen
!****
!!! Row indices of trantab
!!!   dig  cper cplu cmin cexp calp coal cbla cdlm cquo copr coth cunr
! STRT - start state
! SSGN - sign state
! SDIG - digit state
! SPER - period state
! SFRC - fraction state
! SEEX - exponent indicator state
! SSEX - exponent sign state
! SDEX - exponent digit state
! SID  - identifier state
! SDLM - delimiter state
! SSTR - string state
! SOPR - operator state
! SOTH - other character state
! SUNR - unrecognizable character state
! ..
! .. Function Return Value ..
          INTEGER :: next_state
! ..
! .. Parameters ..
          INTEGER, PARAMETER :: trantb(13,14) = RESHAPE((/sdig,sper,sopr, &
            sopr,sid,sid,soth,strt,snll,sstr,sopr,soth,sunr,sdig,sper, &
            snll,snll,snll,snll,snll,ssgn,snll,snll,snll,snll,snll,sdig, &
            sper,snll,snll,seex,soth,soth,snll,snll,soth,snll,soth,snll, &
            sfrc,soth,snll,snll,seex,soth,soth,snll,snll,soth,snll,soth, &
            snll,sfrc,soth,snll,snll,seex,soth,soth,snll,snll,soth,snll, &
            soth,snll,sdex,soth,ssex,ssex,soth,soth,soth,snll,soth,soth, &
            soth,soth,snll,sdex,soth,soth,soth,soth,soth,soth,snll,soth, &
            soth,soth,soth,snll,sdex,soth,snll,snll,soth,soth,soth,snll, &
            snll,soth,snll,soth,snll,sid,sid,snll,snll,sid,sid,sid,snll, &
            snll,soth,snll,soth,snll,snll,snll,snll,snll,snll,snll,snll, &
            snll,snll,snll,snll,snll,snll,sstr,sstr,sstr,sstr,sstr,sstr, &
            sstr,sstr,sstr,sstr,sstr,sstr,sstr,snll,snll,sopr,sopr,snll, &
            snll,snll,snll,snll,snll,sopr,snll,snll,soth,soth,soth,soth, &
            soth,soth,soth,snll,soth,soth,soth,soth,snll,snll,snll,snll, &
            snll,snll,snll,snll,snll,snll,snll,snll,snll,sunr/), &
            shape=(/13,14/))
! ..
! .. Scalar Arguments ..
          INTEGER, INTENT (IN) :: class, state
! ..
! .. Intrinsic Functions ..
          INTRINSIC RESHAPE
! ..
!!! Row indices of trantab
!!!   dig  cper cplu cmin cexp calp coal cbla cdlm cquo copr coth cunr
          next_state = trantb(class,state)

        END FUNCTION next_state

!.....................................................................

        SUBROUTINE set_numeric_values
! .. Intrinsic Functions ..
          INTRINSIC INT
! ..
          IF (curtyp==typin) THEN
! INTEGER value

            dval = sign*intpt

            IF (intpt<=dimax) THEN
              indov = 0
              ival = sign*INT(intpt)
            ELSE IF (intpt<=drmax) THEN
              indov = 1
              ival = 0
            ELSE
              indov = 2
              ival = 0
            END IF
          ELSE IF (curtyp==typrl) THEN
! REAL value

            dval = intpt + fracpt

            IF (exppt>=REAL(imax,kind=dpkind)) THEN
              indov = 3
              ival = 0
              dval = zero
              prvtyp = curtyp
              qlex = .TRUE.

              RETURN

            END IF

            i = INT(exppt)
            DO j = 1, i
              IF (esign==1) THEN
                IF (dval<=dmax10) THEN
                  dval = dval*ten
                ELSE
                  indov = 3
                  ival = 0
                  dval = zero
                  prvtyp = curtyp
                  qlex = .TRUE.

                  RETURN

                END IF
              ELSE
                dval = dval*tenth
              END IF
            END DO

            indov = 2

            IF (dval<=REAL(rmax,kind=dpkind)) THEN
              indov = 1

              IF (dval<=dimax) THEN
                indov = 0
                ival = INT(dval)
              END IF
            END IF

! Change the sign if the string starts with a '-'

            IF (cval(1:1)=='-') THEN
              ival = -ival
              dval = -dval
            END IF
          ELSE
            ival = 0
            dval = zero
          END IF

!-----------------------------------------------------------------------
!     Return with a TOKEN.
!-----------------------------------------------------------------------
          prvtyp = curtyp
          qlex = .TRUE.

        END SUBROUTINE set_numeric_values

!.....................................................................

      END FUNCTION qlex

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

    END MODULE biomath_strings_mod


text:
Stephanie Hammon is the sports editor at The California Aggie.

She is double majoring in English and American Studies.

She also plays ultimate frisbee for the Pleiades, the 2004 college national champions. She likes to escape Lower Freeborn the basement by throwing frisbees on the quad. If youve ever been hit by an erroneous frisbee while studying or sleeping on the quad, Steph assures you it wasnt her. That would be shadiness factor shady.

One of Stephanies closest friends and confidants is obviously Users/RobPedersen Rob Pedersen.

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
+incdir+${VMON}/src/client/sv

${VMON}/src/client/sv/vmon_client_uvm_pkg.sv

max_stars_repo_name: mballance/vmon

max_issues_repo_name: mballance/vmon

max_forks_repo_name: mballance/vmon


text:
!-> Copyright by Imperial College London, 2008
!
!-> Module.- XBEAM_SHARED Rafa Palacios. 15Jul2008 - Last Update 07Jan2011 Henrik Hesse
!
!-> Description.-
!
!  This module defines shared parameters and type definitions shared by all
!  XBeam routines.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module xbeam_shared
    use, intrinsic          :: iso_c_binding
 implicit none

! Problem constants.
 integer,parameter:: MaxElNod=3                ! Max number of nodes per element.
 real(8),parameter:: Pi=3.14159265358979
 real(8),parameter,private,dimension(3,3):: Unit= &    ! Unit matrix.
&         reshape((/1.d0,0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,1.d0/),(/3,3/))

! Define derived types with default values:

! Element information.
 type xbelem
  integer:: NumNodes = 0               ! Number of nodes in the element.
  integer:: MemNo = 0                 ! Member to which the element belongs.
  integer:: Conn   (MaxElNod) = 0
    ! Connectivities (i.e., for each node, contains the local number to global number association)
  integer:: Master (MaxElNod,2) = 0   ! Master node for each node j in the element.
                                   ! (j,1): # master elem  (or 0 if current is master).
                                   ! (j,2): Node within master element (or 0 if current is master).
  real(8):: Length = 0.0d0                ! Length in the undeformed configuration.
  real(8):: PreCurv (3) = 0.0d0            ! Initial curvature of the element.
  real(8):: Psi     (3) = 0.0d0            ! Rotation vector of (undeformed) element frame.
  real(8):: Vector  (3) = 0.0d0            ! Element orientatIon vector. It goes along the local Y axis.
                                   ! sm: this defines the element y axis and is in the a frame components
  real(8):: Mass    (6,6) = 0.0d0          ! Mass matrix (constant along the element).
  real(8):: Stiff   (6,6) = 0.0d0          ! Element stiffness (constant along the element).
  real(8):: InvStiff(6,6) = 0.0d0          ! Inverse of the element stiffness (constant along the element).
  real(8):: RBMass  (MaxElNod,6,6) = 0.0d0 ! Non-Structural (lumped) mass at element nodes.
 end type xbelem

! Nodal information.
 type xbnode
  integer:: Master (2) = 0         ! Master node for current node.
                                   ! (1): # master elem.
                                   ! (2): # node within master element.
  integer:: Vdof  = 0                  ! Number of node for which displacements and rotations are unknown
                                   ! (free -internal and not - and clamped) in the velocity/displacements vector
                                   ! For clamped node, this signifies weak enforcement of BCs.
  integer:: Fdof = 0                  ! Number of node in the force vector for which all the forces/moments need to be computed
                                   ! (clamped BC, internal nodes)
  integer:: Sflag=0                ! Flag for spherical joint at the node (1: hinged, 0: no hinge)
                                   ! This will imply weak enforcement of BCs.
                                   ! Only working for static solver and solution 912

 end type xbnode

! Simulation options (with default values).
 type, bind(C) :: xbopts
  logical(c_bool):: FollowerForce   =.true.   ! =T: Follower force.
  logical(c_bool):: FollowerForceRig=.true.   ! =T: Follower force in the body-fixed frame.
  logical(c_bool):: PrintInfo    =.true.      ! =T: Print information on screen.
  logical(c_bool):: OutInBframe  =.false.      ! =T print velocities in B-frame (if not, use a-frame)
  logical(c_bool):: OutInaframe  =.true.     ! =T print velocities in a-frame (if not, Inertial frame)
  integer(c_int):: ElemProj     = 0          ! =0: Element info computed in the global frame.
                                      ! =1: Element info computed in a fixed element frame.
                                      ! =2: Element info computed in a moving element frame.
  integer(c_int):: MaxIterations=99          ! Maximum number of iterations.
  integer(c_int):: NumLoadSteps=1            ! Number of load increments.
  integer(c_int):: NumGauss=2                ! Number of Gauss points in the integration.
  integer(c_int):: Solution=111              ! Solution process:
                                      ! =102/112: cbeam3 linear/nonlinear static.
                                      ! =202/212: cbeam3 linear/nonlinear structural dynamic
                                      ! =302/312: cbeam3 linear/nonlinear static + structural dynamic
                                      ! =900/910:        linear/nonlinear rigid-body dynamic
                                      ! =902/912: cbeam3 linear/nonlinear flexible-body dynamic
                                      ! =    922: cbeam3 nonlinear static + flexible-body dynamic
                                      ! =    952: cbeam3 linear flexible with nonlinear rigid-body dynamic
  real(c_double):: DeltaCurved=1d-2          ! Minimum angle for two unit vectors to be parallel.
  real(c_double):: MinDelta=1d-8             ! Convergence parameter for Newton-Raphson iterations.
  real(c_double):: NewmarkDamp=1.d-4         ! Numerical damping in the Newmark integration scheme.
  logical(c_bool):: gravity_on = .FALSE.
  real(c_double):: gravity = 0.0d0
  real(c_double):: gravity_dir_x = 0
  real(c_double):: gravity_dir_y = 0
  real(c_double):: gravity_dir_z = 1
  logical(c_bool):: balancing = .false.
  real(c_double):: relaxation_factor = 0.3
 end type

end module xbeam_shared

max_stars_repo_name: fonsocarre/xbeam

max_issues_repo_name: ImperialCollegeLondon/xbeam

max_forks_repo_name: fonsocarre/xbeam


text:
  PROGRAM hello_world
  USE OMP_LIB

  !$OMP PARALLEL
  PRINT *, "Hello from thread: ", OMP_GET_THREAD_NUM()
  !$OMP END PARALLEL

  END PROGRAM hello_world

max_stars_repo_name: DarkGenerators/DaskOnSnellius

max_issues_repo_name: DarkGenerators/DaskOnSnellius

max_forks_repo_name: DarkGenerators/DaskOnSnellius


text:
Precious Cargo Pet Taxi will transport your pets pet for you anywhere in northern California and also offers pet sitting and day care. Headquartered in Vacaville, Precious Cargo is licensed, bonded and insured. They advertise affordable rates and discounts for seniors, military personnel, disabled individuals and those with multiple pets. References are available upon request and gift certificates are available in any amount. The owner is a mature, animal medical trained professional with experience & long time California residence & pet lover, gladly willing to provide wonderful references upon your request!

 Services
  Pet Transportation Transport
   Airports Airport related transport
   To Veterinary Hospitals vets or Pet Grooming pet groomers, they will even make the appointment for you
  Dogs Dog walking
  Pet Relocation Services
  Emergency transport
  Inhome services
   Custom Pet Sitting
   Administering Medicine
   home visits when you cant get there
  Assistance with lost pets
  Deceased Pet Removal Assistance
  Lock Box, Office Key PickUp & Key on File Service is offered too.

20060314 19:52:12 nbsp Glad to be part of the Davis Wiki community !!!  Mari ~ Owner: Precious Cargo Pet Taxi Users/MariHayward


text:
(* Automatic netwerk (one ring) simple buildup with demo programm
*)

: BUILD     ( -- )
    ." from " .status               \ Show nRF24 status
    scanx cr  ch s direct >others   \ SCANX on myself & all new found nodes
    hop cr  ch h direct >others     \ HOP on myself & all new found nodes
    info cr  ch i direct >others ;  \ Gather all node information & ready

: RUNNER    ( -- )      \ Running light on all outputs in my network
    run  begin
        all >user
        begin  user next? while
        dup on  100 <wait>
        off  30 <wait>  repeat
    halt? until ;

: START-MESH ( -- )
    startnode  cr build  cr runner ;

\ End ;;;

max_stars_repo_name: embeddingforth/embeddinForth

max_issues_repo_name: embeddingforth/embeddinForth

max_forks_repo_name: embeddingforth/embeddinForth


text:
*..............................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !ROUTINE: ODS_NGet --- Returns the number of observation reports
!
! !DESCRIPTION:
!    \label{ODS:NGet}
!     Returns the number of observation reports for a given
!     julian day and synoptic hour
!
!     Note: For a list of error codes, see Table~\ref{tab:errors}.
!
! !INTERFACE:
!
      integer function ODS_NGet ( id, julian_day, syn_hour, ierr )
!
! !INPUT PARAMETERS:
      implicit   NONE
      integer    id                ! ODS file handle
      integer    julian_day        ! Julian day.  Use the function
                                   !   ODS_Julian to obtain this
                                   !   number.
      integer    syn_hour          ! hour of synoptic time since
                                   !   0:00 GMT (e.g., 0, 6, 12,
                                   !   18)
!
! !OUTPUT PARAMETERS:
!     integer    NObs              ! Number of observation report
      integer    ierr              ! Error code. If non-zero, an
                                   !  error has occurred. For a list
                                   !  of possible values, see the
                                   !  description section of this
                                   !  prologue.
!
! !SEE ALSO:
!     ODS_IGet()    gets the integer of a user-selected
!                   NetCDF file parameter
!     ODS_RGet()    gets the floating point value of a user-selected
!                   NetCDF file parameter
!     ODS_CGet()    gets the character string of a user-selected
!                   NetCDF file parameter
!     ODS_Julian()  converts the "calendar" date to the Julian day
!
! !REVISION HISTORY:
!     13Apr1996   Redder   Original version.  Routine developed to
!                          create ODS version 2.00
!     20Apr1998   Redder   Correct bug in error message
!     19Nov1999   Redder   Added a latex label in and moved the
!                          subroutine statement into the prologue.
!                          Modified the comments for the return status
!                          code.
!     06Dec1999   Redder   Corrections to the documentation in the
!                          prologue.
!
!EOP
!-------------------------------------------------------------------------

      include 'netcdf.inc'
      include 'ods_hdf.h'
      include 'ods_stdio.h'

*     Indices defining the set of observation data
*     corresponding to a synoptic time in the ODS file
*     ------------------------------------------------
      integer  synbeg      ! starting index for the data block
      integer  synlen      ! number of observation reports in
                           !   the data block

*     Set output parameters to default
*     --------------------------------
      ODS_NGet = 0
      ierr     = NCNoErr

*     Check to determine if the file handle id is valid
*     -------------------------------------------------
      if ( id            .lt. 1      .or.
     .     id            .gt. id_max .or.
     .     IOMode ( id ) .eq. CLOSED ) then
         write ( stderr, 901 )
         ierr = NCEBadID
         return
      end if

*     Get pointer data from tables stored in common
*     ---------------------------------------------
      call ODS_GetP    ( id,        'write',
     .                   julian_day, syn_hour,
     .                   synbeg,     synlen,  ierr )
      if ( ierr .ne. NCNoErr ) return

*     The number of observation reports
*     be can extracted from pointer data
*     ----------------------------------
      ODS_NGet = synlen

      return
*     ------

 901  format ( /, ' ODS_NGet: File handle id number does not ',
     .         /, '           correspond to an opened ODS file' )

      end

max_stars_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


text:
subroutine triad(a, b, scalar, c)
real, intent(in) :: a(:), b(:), scalar
real, intent(out) :: c(:)
integer :: N, i
N = size(a)
do concurrent (i = 1:N)
    c(i) = a(i) + scalar * b(i)
end do
end subroutine

max_stars_repo_name: Thirumalai-Shaktivel/lfortran

max_issues_repo_name: Thirumalai-Shaktivel/lfortran

max_forks_repo_name: Thirumalai-Shaktivel/lfortran


text:
! Copyright (c) 2005-2010, 2012-2013, Andrew Hang Chen and contributors,
! All rights reserved.
! Licensed under the 3-clause BSD license.

program fruit_driver
  use fruit
  use calculator_test
  call init_fruit                  !in f95, subroutine name limited to 31 characters
  call test_calculator_should_produce_4_when_2_and_2_are_inputs
  call fruit_summary
  call fruit_finalize
end program fruit_driver

max_stars_repo_name: thomasms/fortran-examples

max_issues_repo_name: thomasms/fortran-examples

max_forks_repo_name: jrwrigh/libFRUIT


text:
c
c
c ... file rgrd4u.f
c
c     this file contains documentation for subroutine rgrd4u followed by
c     fortran code for rgrid4u and additional subroutines.
c
c ... author
c
c     John C. Adams (NCAR 1999)
c
c ... subroutine rgrd4u(nx,ny,nz,nt,p,mx,my,mz,mt,q,intpol,w,lw,iw,liw,ier)
c
c ... purpose
c
c     subroutine rgrd4u interpolates the nx by ny by nz by nt array p onto
c     the mx by my by mz by mt array q.  it is assumed that p and q are
c     values on uniform nx by ny by nz by nt and mx by my by mz by mt grids
c     which are superimposed on the same box region (INCLUDING BOUNDARIES).
c     if p and q are values on nonuniform orthogonal grids and/or if the grid
c     on which q is defined lies within the p grid then subroutine rgrd4
c     (see file rgrd4.f) should be used.
c
c ... language
c
c     coded in portable FORTRAN77 and FORTRAN90
c
c ... test program
c
c     file trgrd4u.f on regridpack includes a test program for subroutine rgrd4u
c
c ... method
c
c     linear or cubic interpolation (see intpol) is used in each
c     direction for which the q grid is not a subgrid of the p grid.
c     [the mx (my,mz,mt) uniform grid is a subgrid of the nx (ny,nz,nt)
c     uniform grid if and only if mx-1 (my-1,nz-1,nt-1) divides nx-1
c     (ny-1,nz-1,nt-1)].  Values are set directly without (the need for)
c     interpolation in subgrid directions.
c
c ... required files
c
c     files rgrd3u.f,rgrd2u.f and rgrd1u.f must be loaded with rgrd4u.f.  they
c     include subroutines called by the routines in rgrd4u.f
c
c ... efficiency
c
c     inner most loops in regridpack software vectorize.  If the
c     integer arguments mx,my,mz,mt (see below) have different values,
c     optimal vectorization will be achieved if they are arranged so that
c     mx > my > mz > mt.
c
c *** input arguments ***
c
c
c ... nx
c
c     the integer first dimension of p.  nx > 1 if intpol(1) = 1 or
c     nx > 3 if intpol(1) = 3 is required (see ier = 2).
c
c ... ny
c
c     the integer second dimension of p.  ny > 1 if intpol(2) = 1 or
c     ny > 3 if intpol(2) = 3 is required (see ier = 2).
c
c
c ... nz
c
c     the integer third dimension of p.  nz > 1 if intpol(3) = 1 or
c     nz > 3 if intpol(3) = 3 is required (see ier = 2)
c
c ... nt
c
c     the integer fourth dimension of p.  nt > 1 if intpol(4) = 1 or
c     nt > 3 if intpol(4) = 3 is required (see ier=2)
c
c ... p
c
c     a real nx by ny by nz by nt array of given values
c
c ... mx
c
c     the integer first dimension of q.  mx > 1 is required (see ier = 1)
c
c ... my
c
c     the integer second dimension of q. my > 1 is required (see ier = 1)
c
c ... mz
c
c     the integer third dimension of q. mz > 1 is required (see ier = 1)

c ... mt
c
c     the integer fourth dimension of q. mt > 1 is required (see ier = 1)
c
c ... intpol
c
c     an integer vector of dimension 4 which sets linear or cubic
c     interpolation in each of the x,y,z,t directions as follows:
c
c        intpol(1) = 1 sets linear interpolation in the x direction
c        intpol(1) = 3 sets cubic interpolation in the x direction.
c
c        intpol(2) = 1 sets linear interpolation in the y direction
c        intpol(2) = 3 sets cubic interpolation in the y direction.
c
c        intpol(3) = 1 sets linear interpolation in the z direction
c        intpol(3) = 3 sets cubic interpolation in the z direction.
c
c        intpol(4) = 1 sets linear interpolation in the t direction
c        intpol(4) = 3 sets cubic interpolation in the t direction.
c
c     values other than 1 or 3 in intpol are not allowed (ier = 3).
c
c ... w
c
c     a real work space of length at least lw which must be provided in the
c     routine calling rgrd4u
c
c ... lw
c
c     the integer length of the work space w.
c
c          let lwx = 1 if mx-1 divides nx-1; otherwise
c          let lwx = mx if intpol(1) = 1 or
c          let lwx = 4*mx if intpol(1) = 3
c
c          let lwy = 0 if my-1 divides ny-1; otherwise
c          let lwy = my+2*mx if intpol(2) = 1 or
c          let lwy = 4*(mx+my) if intpol(2) = 3
c
c          let lwz = 0 if mz-1 divides nz-1; otherwise
c          let lwz = 2*mx*my+mz if intpol(3) = 1 or
c          let lwz = 4*(mx*my+mz) if intpol(3) = 3
c
c          let lwt = 0 if mt-1 divides nt-1; otherwise
c          let lwt = 2*mx*my*mz+mt if intpol(4) = 1 or
c          let lwt = 4*(mx*my*mz+mt) if intpol(4) = 3
c
c     then lw must be greater than or equal to lwx+lwy+lwz+lwt
c
c ... iw
c
c     an integer work space of length at least liw which must be provided in the
c     routine calling rgrd4u
c
c ... liw
c
c     the integer length of the integer work space iw.  liw must be at least
c     mx+my+mz+mt
c
c
c *** output arguments ***
c
c
c ... q
c
c     a real mx by my by mz by mt array of values which are interpolated
c     from p.
c
c ... ier
c
c     an integer error flag set as follows:
c
c     ier = 0 if no errors in input arguments are detected
c
c     ier = 1 if  min0(mx,my,mz,mt) < 2
c
c     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
c                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3 (or)
c                nz < 2 when intpol(3)=1 or nz < 4 when intpol(3)=3 (or)
c                nt < 2 when intpol(4)=1 or nt < 4 when intpol(4)=3.
c
c     ier = 3 if any of intpol(1),intpol(2),intpol(3),intpol(4)  is not
c             equal to 1 or 3.
c
c     ier = 4 if lw or liw is too small (insufficient work space)
c
c ************************************************************************
c
c     end of rgrd4u documentation, fortran code follows:
c
c ************************************************************************
c
      subroutine rgrd4u(nx,ny,nz,nt,p,mx,my,mz,mt,q,intpol,
     +                  w,lw,iw,liw,ier)
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt,intpol(4),liw,iw(liw),lw,ier
      real p(nx,ny,nz,nt),q(mx,my,mz,mt),w(lw)
      integer inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt
      integer mxmy,mxmymz,lwx,lwy,lwz,lwt,jy,kz,lt
      integer i2,i3,i4,i5
      integer j2,j3,j4,j5,j6,j7,j8,j9
      integer k2,k3,k4,k5,k6,k7,k8,k9
      integer l2,l3,l4,l5,l6,l7,l8,l9
c
c
c     check input arguments
c
      ier = 1
c
c     check mx,my,mz,mt
c
      if (min0(mx,my,mz,mt) .lt. 1) return
c
c     check intpol
c
      ier = 3
      if (intpol(1).ne.1 .and. intpol(1).ne.3) return
      if (intpol(2).ne.1 .and. intpol(2).ne.3) return
      if (intpol(3).ne.1 .and. intpol(3).ne.3) return
      if (intpol(4).ne.1 .and. intpol(4).ne.3) return
c
c     check nx,ny,nz,nt
c
      ier = 2
      if (intpol(1).eq.1 .and. nx.lt.2) return
      if (intpol(1).eq.3 .and. nx.lt.4) return
      if (intpol(2).eq.1 .and. ny.lt.2) return
      if (intpol(2).eq.3 .and. ny.lt.4) return
      if (intpol(3).eq.1 .and. nz.lt.2) return
      if (intpol(3).eq.3 .and. nz.lt.4) return
      if (intpol(4).eq.1 .and. nt.lt.2) return
      if (intpol(4).eq.3 .and. nt.lt.4) return
c
c     set subgrid indicators
c
      inmx = (nx-1)/(mx-1)
      jnmy = (ny-1)/(my-1)
      knmz = (nz-1)/(mz-1)
      lnmt = (nt-1)/(mt-1)
      isubx = nx - inmx*(mx-1)
      jsuby = ny - jnmy*(my-1)
      ksubz = nz - knmz*(mz-1)
      lsubt = nt - lnmt*(mt-1)
c
c     check work space length input
c
      ier = 4
      mxmy = mx*my
      mxmymz = mxmy*mz
      lwx = 1
      if (isubx.ne.1) then
	if (intpol(1).eq.1) then
	  lwx = mx
	else
	  lwx = 4*mx
	end if
      end if
      lwy = 0
      if (jsuby.ne.1) then
	if (intpol(2).eq.1) then
	  lwy = (2*mx+my)
	else
	  lwy = 4*my+4*mx
	end if
      end if
      lwz = 0
      if (ksubz.ne.1) then
	if (intpol(3).eq.1) then
	  lwz = (2*mxmy+mz)
	else
	  lwz = 4*mxmy+4*mz
	end if
      end if
      lwt = 0
      if (lsubt.ne.1) then
	if (intpol(4).eq.1) then
	  lwt = (2*mxmymz+mt)
	else
	  lwt = 4*mxmymz+4*mt
	end if
      end if

      if (lw .lt. lwx+lwy+lwz+lwt) return
      if (liw .lt. mx+my+mz+mt) return
c
c     arguments o.k.
c
      ier = 0
      jy = mx+1
      kz = mx+my+1
      lt = mx+my+mz+1

      if (intpol(4).eq.1) then
c
c     linearly interpolate in nt, set work space pointers and scales
c

	l2 = 1
	l3 = l2
	l4 = l3+mt
	l5 = l4
	l6 = l5
	l7 = l6
	l8 = l7+mxmymz
	l9 = l8+mxmymz
	call linmxu(nt,mt,iw(lt),w(l3))
	k2 = l9
	if (intpol(3).eq.1) then
c     linear in z
	  k3 = k2
	  k4 = k3+mz
	  k5 = k4
	  k6 = k5
	  k7 = k6
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call linmxu(nz,mz,iw(kz),w(k3))
	  j2 = k9
	else
c     cubic in z
	  k3 = k2+mz
	  k4 = k3+mz
	  k5 = k4+mz
	  k6 = k5+mz
	  k7 = k6+mxmy
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call cubnmxu(nz,mz,iw(kz),w(k2),w(k3),w(k4),w(k5))
	  j2 = k9+mxmy
	end if

	if (intpol(2) .eq. 1) then
c     linear in y
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
	  call linmxu(ny,my,iw(jy),w(j3))
	  i2 = j9
	else
c     cubic in y
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
	  call cubnmxu(ny,my,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 = j9+mx
	end if

	if (intpol(1) .eq. 1) then
c     linear in x
	  i3 = i2
	  i4 = i3
	  i5 = i4
	  call linmxu(nx,mx,iw,w(i3))
	else
c     cubic in x
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	  call cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
c
c     linearly interpolate in t
c
	call lint4u(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +  iw(lt),w(l3),w(l7),w(l8),
     +  iw(kz),w(k2),w(k3),w(k4),w(k5),w(k6),w(k7),w(k8),w(k9),
     +  iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),
     +  iw,w(i2),w(i3),w(i4),w(i5),
     +  inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt)
	return

      else
c
c     cubically interpolate in t
c
	l2 = 1
	l3 = l2+mt
	l4 = l3+mt
	l5 = l4+mt
	l6 = l5+mt
	l7 = l6+mxmymz
	l8 = l7+mxmymz
	l9 = l8+mxmymz
	call cubnmxu(nt,mt,iw(lt),w(l2),w(l3),w(l4),w(l5))
	k2 = l9+mxmymz

	if (intpol(3).eq.1) then
c     linear in z
	  k3 = k2
	  k4 = k3+mz
	  k5 = k4
	  k6 = k5
	  k7 = k6
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call linmxu(nz,mz,iw(kz),w(k3))
	  j2 = k9
	else
c     cubic in z
	  k3 = k2+mz
	  k4 = k3+mz
	  k5 = k4+mz
	  k6 = k5+mz
	  k7 = k6+mxmy
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call cubnmxu(nz,mz,iw(kz),w(k2),w(k3),w(k4),w(k5))
	  j2 = k9+mxmy
	end if

	if (intpol(2) .eq. 1) then
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
	  call linmxu(ny,my,iw(jy),w(j3))
	  i2 = j9
	else
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
	  call cubnmxu(ny,my,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 = j9+mx
	end if
c
c     set work space portion and indices which depend on x interpolation
c
	if (intpol(1) .eq. 1) then
	  i3 = i2
	  i4 = i3
	  i5 = i4
	  call linmxu(nx,mx,iw,w(i3))
	else
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	  call cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
c
c     cubically interpolate in t
c
	call cubt4u(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +  iw(lt),w(l2),w(l3),w(l4),w(l5),w(l6),w(l7),w(l8),w(l9),
     +  iw(kz),w(k2),w(k3),w(k4),w(k5),w(k6),w(k7),w(k8),w(k9),
     +  iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),
     +  iw,w(i2),w(i3),w(i4),w(i5),
     +  inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt)
	return
      end if
      end

      subroutine lint4u(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +lt,dt,pt,ptp,kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt)
c
c     linearly interpolate in t direction
c
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt
      integer mxmy,mxmymz
      real p(nx,ny,nz,nt),q(mxmymz,mt)
      integer inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt
      real dt(mt),pt(mxmymz),ptp(mxmymz)
      real dzm(mz),dz(mz),dzp(mz),dzpp(mz)
      real pkm(mxmy),pk(mxmy),pkp(mxmy),pkpp(mxmy)
      real dym(my),dy(my),dyp(my),dypp(my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
      integer lt(mt),kz(mz),jy(my),ix(mx),intpol(4)
      integer l,ll,lsave,iijjkk
      if (intpol(3) .eq. 1) then
c
c     linear in z
c
      if (lsubt .eq. 1) then
c
c     mt grid is subset of nt grid
c
       do ll=1,mt
	l = lnmt*(ll-1)+1
	call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,q(1,ll),intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end do
       return
       end if

       lsave = -1
       do ll=1,mt
	l = lt(ll)
	if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
	else if (l.eq.lsave+1) then
c
c     update l and interpolate l+1
c
	 do iijjkk=1,mxmymz
	  pt(iijjkk) = ptp(iijjkk)
	 end do
	 call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +   dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp
     +   ,inmx,jnmy,knmz,isubx,jsuby,ksubz)
	else
c
c     interpolate l,l+1 in pt,ptp on xx,yy,zz mesh
c
	 call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,dz,
     +   pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +   inmx,jnmy,knmz,isubx,jsuby,ksubz)
	 call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +   dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp
     +   ,inmx,jnmy,knmz,isubx,jsuby,ksubz)
	end if
c
c     save l pointer for next pass
c
	lsave = l
c
c     linearly interpolate q(ii,jj,,kk,ll) from pt,ptp in t direction
c
	do iijjkk=1,mxmymz
	 q(iijjkk,ll) = pt(iijjkk)+dt(ll)*(ptp(iijjkk)-pt(iijjkk))
	end do
       end do
       return

      else
c
c     cubic in z
c
       if (lsubt .eq. 1) then
c
c     mt grid is subset of nt grid
c
	do ll=1,mt
	 l = lnmt*(ll-1)+1
	 call cubt3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,q(1,ll),intpol,
     +   kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,
     +   pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +   inmx,jnmy,knmz,isubx,jsuby,ksubz)
	end do
	return
       end if
       lsave = -1
       do ll=1,mt
       l = lt(ll)
       if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
       else if (l.eq.lsave+1) then
c
c     update l and interpolate l+1
c
       do iijjkk=1,mxmymz
	pt(iijjkk) = ptp(iijjkk)
       end do
       call cubt3u(nx,ny,nt,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,
     + kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     + jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     + inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else
c
c     interpolate l,l+1 in pt,ptp on xx,yy,zz mesh
c
       call cubt3u(nx,ny,nt,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,
     + kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     + jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     + inmx,jnmy,knmz,isubx,jsuby,ksubz)
       call cubt3u(nx,ny,nt,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,
     + kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     + jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     + inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end if
c
c     save l pointer for next pass
c
       lsave = l
c
c     linearly interpolate q(ii,jj,kk,ll) from pt,ptp in t direction
c
       do iijjkk=1,mxmymz
	q(iijjkk,ll) = pt(iijjkk)+dt(ll)*(ptp(iijjkk)-pt(iijjkk))
       end do

      end do
      return

      end if
      end

      subroutine cubt4u(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +lt,dtm,dt,dtp,dtpp,ptm,pt,ptp,ptpp,
     +kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt)
c
c
c     cubically interpolate in t
c
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt
      integer inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt
      integer mxmy,mxmymz
      real p(nx,ny,nz,nt),q(mxmymz,mt)
      real ptm(mxmymz),pt(mxmymz),ptp(mxmymz),ptpp(mxmymz)
      real dtm(mt),dt(mt),dtp(mt),dtpp(mt)
      real dzm(mz),dz(mz),dzp(mz),dzpp(mz)
      real pkm(mxmy),pk(mxmy),pkp(mxmy),pkpp(mxmy)
      real dym(my),dy(my),dyp(my),dypp(my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
      integer lt(mt),kz(mz),jy(my),ix(mx),intpol(4)
      integer l,ll,iijjkk,lsave
      if (intpol(3) .eq. 1) then
c
c     linear in z
c
      if (lsubt .eq. 1) then
c
c     mt grid is subset of nt grid
c
       do ll=1,mt
	l = lnmt*(ll-1)+1
	call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,q(1,ll),intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end do
       return
      end if
      lsave = -3
      do ll=1,mt
       l = lt(ll)
       if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
       else if (l.eq.lsave+1) then
c
c     update l-1,l,l+1 and interpolate l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = pt(iijjkk)
	 pt(iijjkk) = ptp(iijjkk)
	 ptp(iijjkk) = ptpp(iijjkk)
	end do
	call lint3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else if (l.eq.lsave+2) then
c
c     update l-1,l and interpolate l+1,l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = ptp(iijjkk)
	 pt(iijjkk) = ptpp(iijjkk)
	end do
	call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else if (l.eq.lsave+3) then
c
c     update l-1 and interpolate l,l+1,l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = ptpp(iijjkk)
	end do
	call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else
c
c     interpolate all four l-1,l,l+1,l+2
c
	call lint3u(nx,ny,nz,p(1,1,1,l-1),mx,my,mxmy,mz,ptm,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end if
c
c     save l pointer for next pass
c
       lsave = l
c
c     cubically interpolate q(ii,jj,kk,ll) from ptm,pt,ptp,ptpp in t direction
c
       do iijjkk=1,mxmymz
	q(iijjkk,ll) = dtm(ll)*ptm(iijjkk) + dt(ll)*pt(iijjkk) +
     +                 dtp(ll)*ptp(iijjkk) + dtpp(ll)*ptpp(iijjkk)
       end do
      end do
      return

      else
c
c     cubic in z
c
      if (lsubt .eq. 1) then
c
c     mt grid is subset of nt grid
c
       do ll=1,mt
	l = lnmt*(ll-1)+1
	call cubt3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,q(1,ll),intpol,
     +  kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,
     +  pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end do
       return
      end if
      lsave = -3
      do ll=1,mt
       l = lt(ll)
       if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
       else if (l.eq.lsave+1) then
c
c     update l-1,l,l+1 and interpolate l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = pt(iijjkk)
	 pt(iijjkk) = ptp(iijjkk)
	 ptp(iijjkk) = ptpp(iijjkk)
	end do
	call cubt3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else if (l.eq.lsave+2) then
c
c     update l-1,l and interpolate l+1,l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = ptp(iijjkk)
	 pt(iijjkk) = ptpp(iijjkk)
	end do
	call cubt3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else if (l.eq.lsave+3) then
c
c     update l-1 and interpolate l,l+1,l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = ptpp(iijjkk)
	end do
	call cubt3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else
c
c     interpolate all four l-1,l,l+1,l+2
c
	call cubt3u(nx,ny,nz,p(1,1,1,l-1),mx,my,mxmy,mz,ptm,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end if
c
c     save l pointer for next pass
c
       lsave = l
c
c     cubically interpolate q(ii,jj,kk,ll) from ptm,pt,ptp,ptpp in t direction
c
       do iijjkk=1,mxmymz
	q(iijjkk,ll) = dtm(ll)*ptm(iijjkk) + dt(ll)*pt(iijjkk) +
     +                 dtp(ll)*ptp(iijjkk) + dtpp(ll)*ptpp(iijjkk)
       end do
      end do
      return
      end if

      end

max_stars_repo_name: xylar/cdat

max_issues_repo_name: xylar/cdat

max_forks_repo_name: CDAT/uvcdat


program main

  use DataInputM
  use ThermalStruct2DApplicationM
  use SolvingStrategyM
  use ThermalStrategyM
  use StructuralStrategyM
  use GIDDataOutputM

  implicit none

  type(ThermalStruct2DApplicationDT) :: application
  type(SolvingStrategyDT)            :: solvingStrategy
  type(ThermalStrategyDT)            :: thermalStrategy
  type(StructuralStrategyDT)         :: structuralStrategy

  call initFEM2D(application)
  solvingStrategy = InitSolvingStrategy(thermalStrategy, application%thermalModel)
  call solvingStrategy%useStrategy()
  call initDataOutput()
  call printResults(resultName = 'Temperature'              &
       , step         = 1                                   &
       , graphType    = 'Scalar'                            &
       , locationName = 'onNodes'                           &
       , resultNumber = application%thermalModel%getnNode()  &
       , component1   = application%thermalModel%dof         )
  call printResults(resultName = 'FluxOnTriangs'                            &
       , type         = 'Triangle'                                          &
       , step         = 1                                                   &
       , graphType    = 'Vector'                                            &
       , locationName = 'onGaussPoints'                                     &
       , gaussPoints  = application%thermalModel%heatFlux%triangGPoint       &
       , resultNumber = size(application%thermalModel%heatFlux%triangElemID) &
       , elemID       = application%thermalModel%heatFlux%triangElemID       &
       , component1   = application%thermalModel%heatFlux%triangFlux(:,1)    &
       , component2   = application%thermalModel%heatFlux%triangFlux(:,2)    )
  call printResults(resultName = 'FluxOnQuads'                             &
       , type         = 'Quadrilateral'                                    &
       , step         = 1                                                  &
       , graphType    = 'Vector'                                           &
       , locationName = 'onGaussPoints'                                    &
       , gaussPoints  = application%thermalModel%heatFlux%quadGPoint        &
       , resultNumber = size(application%thermalModel%heatFlux%quadElemID)  &
       , elemID       = application%thermalModel%heatFlux%quadElemID        &
       , component1   = application%thermalModel%heatFlux%quadFlux(:,1)     &
       , component2   = application%thermalModel%heatFlux%quadFlux(:,2)    )

  call application%transitionToStructural()

  solvingStrategy = InitSolvingStrategy(structuralStrategy, application%structuralModel)
  call solvingStrategy%useStrategy()

  call printResults(resultName = 'Displacement'                &
       , step         = 1                                      &
       , graphType    = 'Vector'                               &
       , locationName = 'onNodes'                              &
       , resultNumber = application%structuralModel%getnNode()  &
       , nDof         = 2                                      &
       , component1   = application%structuralModel%dof         )

  call printResults(resultName = 'NormalStressOnTriangs'                            &
       , type         = 'Triangle'                                                  &
       , step         = 1                                                           &
       , graphType    = 'Vector'                                                    &
       , locationName = 'onGaussPoints'                                             &
       , gaussPoints  = application%structuralModel%normalStress%triangGPoint        &
       , resultNumber = size(application%structuralModel%normalStress%triangElemID)  &
       , elemID       = application%structuralModel%normalStress%triangElemID        &
       , component1   = application%structuralModel%normalStress%triangNS(:,1)       &
       , component2   = application%structuralModel%normalStress%triangNS(:,2)       )
  call printResults(resultName = 'NormalStressOnQuads'                            &
       , type         = 'Quadrilateral'                                           &
       , step         = 1                                                         &
       , graphType    = 'Vector'                                                  &
       , locationName = 'onGaussPoints'                                           &
       , gaussPoints  = application%structuralModel%normalStress%quadGPoint        &
       , resultNumber = size(application%structuralModel%normalStress%quadElemID)  &
       , elemID       = application%structuralModel%normalStress%quadElemID        &
       , component1   = application%structuralModel%normalStress%quadNS(:,1)       &
       , component2   = application%structuralModel%normalStress%quadNS(:,2)       )

  call printResults(resultName = 'ShearStressOnTriangs'                           &
       , type         = 'Triangle'                                                &
       , step         = 1                                                         &
       , graphType    = 'Scalar'                                                  &
       , locationName = 'onGaussPoints'                                           &
       , gaussPoints  = application%structuralModel%shearStress%triangGPoint       &
       , resultNumber = size(application%structuralModel%shearStress%triangElemID) &
       , elemID       = application%structuralModel%shearStress%triangElemID       &
       , component1   = application%structuralModel%shearStress%triangShS          )
  call printResults(resultName = 'ShearStressOnQuads'                            &
       , type         = 'Quadrilateral'                                          &
       , step         = 1                                                        &
       , graphType    = 'Scalar'                                                 &
       , locationName = 'onGaussPoints'                                          &
       , gaussPoints  = application%structuralModel%shearStress%quadGPoint        &
       , resultNumber = size(application%structuralModel%shearStress%quadElemID)  &
       , elemID       = application%structuralModel%shearStress%quadElemID        &
       , component1   = application%structuralModel%shearStress%quadShS           )

  call printResults(resultName = 'StrainStressOnTriangs'                     &
       , type         = 'Triangle'                                           &
       , step         = 1                                                    &
       , graphType    = 'Vector'                                             &
       , locationName = 'onGaussPoints'                                      &
       , gaussPoints  = application%structuralModel%strain%triangGPoint       &
       , resultNumber = size(application%structuralModel%strain%triangElemID) &
       , elemID       = application%structuralModel%strain%triangElemID       &
       , component1   = application%structuralModel%strain%triangEp(:,1)      &
       , component2   = application%structuralModel%strain%triangEp(:,2)      )
  call printResults(resultName = 'StrainStressOnQuads'                      &
       , type         = 'Quadrilateral'                                     &
       , step         = 1                                                   &
       , graphType    = 'Vector'                                            &
       , locationName = 'onGaussPoints'                                     &
       , gaussPoints  = application%structuralModel%strain%quadGPoint        &
       , resultNumber = size(application%structuralModel%strain%quadElemID)  &
       , elemID       = application%structuralModel%strain%quadElemID        &
       , component1   = application%structuralModel%strain%quadEp(:,1)       &
       , component2   = application%structuralModel%strain%quadEp(:,2)       )

  call finishProgram()

end program main


text:
      module MOD_READPOP

      contains

      subroutine readpop(ifl, T, popnum, pop1, pop2, pop3, rne, n, nd, modhead, jobnum)

      USE MOD_READMS
      USE MOD_READMSI
      USE MOD_ERROR

      IMPLICIT REAL*8(A-H,O-Z)

      real*8    T(ND), RNE(ND), POPNUM(ND*N), POP1(ND*N), POP2(ND*N), POP3(ND*N)
      CHARACTER CNAME*7, CREAD*7, MODHEAD*104, MODREAD*104
      INTEGER   JOBREAD, NSAVE, NDREAD

      CNAME='MODHEAD'

      READ (ifl,'(A7)') cread

      if (cread.ne.cname) then
	   write (6,*) 'READMOD: KEYWORD MISMATCH'
	   write (6,*) cread,cname
         pause
         call error('READPOP: KEYWORD MISMATCH')
	endif
	READ (ifl,'(A104)') MODREAD

      CNAME = 'JOBNUM'

      CALL READMSI1(IFL,JOBread,CNAME,IERR)

      if (jobread.gt.jobnum) jobnum = jobread

      CNAME='N'

      CALL READMSI1(IFL,NSAVE,CNAME,IERR)
      if (nsave .ne. N) then
	   write (6,*) 'READPOP: atomic data file mismatch'
	   stop 'file-read error'
      endif

      CNAME='ND'

      CALL READMSI1(IFL,NDREAD,CNAME,IERR)

      if (nd .ne. NDREAD) then
	   write (6,*) 'READPOP dimension of ND larger than NDREAD'
	   pause
	   stop
      endif

      CNAME='T'
      CALL READMS (IFL,T,ND,CNAME,IERR)

      CNAME='RNE'
      CALL READMS (IFL,RNE,ND,CNAME,IERR)

      CNAME='POPNUM'
      CALL READMS(IFL, POPNUM, ND*N, CNAME, IERR)

      CNAME='POP1'
      CALL READMS(IFL, POP1,   ND*N, CNAME, IERR)

      CNAME='POP2'
      CALL READMS(IFL, POP2,   ND*N, CNAME, IERR)

      CNAME='POP3'
      CALL READMS(IFL, POP3,   ND*N, CNAME, IERR)

      return

      end subroutine

      end module

ext: for

max_stars_repo_name: rtagirov/nessy

max_issues_repo_name: rtagirov/nessy

max_forks_repo_name: rtagirov/nessy-src