!*==ilaenv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ILAENV
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ILAENV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
!
!       .. Scalar Arguments ..
!       CHARACTER*( * )    NAME, OPTS
!       INTEGER            ISPEC, N1, N2, N3, N4
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ILAENV is called from the LAPACK routines to choose problem-dependent
!> parameters for the local environment.  See ISPEC for a description of
!> the parameters.
!>
!> ILAENV returns an INTEGER
!> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
!> if ILAENV < 0:  if ILAENV = -k, the k-th argument had an illegal value.
!>
!> This version provides a set of parameters which should give good,
!> but not optimal, performance on many of the currently available
!> computers.  Users are encouraged to modify this subroutine to set
!> the tuning parameters for their particular machine using the option
!> and problem size information in the arguments.
!>
!> This routine will not function correctly if it is converted to all
!> lower case.  Converting it to all upper case is allowed.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] ISPEC
!> \verbatim
!>          ISPEC is INTEGER
!>          Specifies the parameter to be returned as the value of
!>          ILAENV.
!>          = 1: the optimal blocksize; if this value is 1, an unblocked
!>               algorithm will give the best performance.
!>          = 2: the minimum block size for which the block routine
!>               should be used; if the usable block size is less than
!>               this value, an unblocked routine should be used.
!>          = 3: the crossover point (in a block routine, for N less
!>               than this value, an unblocked routine should be used)
!>          = 4: the number of shifts, used in the nonsymmetric
!>               eigenvalue routines (DEPRECATED)
!>          = 5: the minimum column dimension for blocking to be used;
!>               rectangular blocks must have dimension at least k by m,
!>               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
!>          = 6: the crossover point for the SVD (when reducing an m by n
!>               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
!>               this value, a QR factorization is used first to reduce
!>               the matrix to a triangular form.)
!>          = 7: the number of processors
!>          = 8: the crossover point for the multishift QR method
!>               for nonsymmetric eigenvalue problems (DEPRECATED)
!>          = 9: maximum size of the subproblems at the bottom of the
!>               computation tree in the divide-and-conquer algorithm
!>               (used by xGELSD and xGESDD)
!>          =10: ieee infinity and NaN arithmetic can be trusted not to trap
!>          =11: infinity arithmetic can be trusted not to trap
!>          12 <= ISPEC <= 16:
!>               xHSEQR or related subroutines,
!>               see IPARMQ for detailed explanation
!> \endverbatim
!>
!> \param[in] NAME
!> \verbatim
!>          NAME is CHARACTER*(*)
!>          The name of the calling subroutine, in either upper case or
!>          lower case.
!> \endverbatim
!>
!> \param[in] OPTS
!> \verbatim
!>          OPTS is CHARACTER*(*)
!>          The character options to the subroutine NAME, concatenated
!>          into a single character string.  For example, UPLO = 'U',
!>          TRANS = 'T', and DIAG = 'N' for a triangular routine would
!>          be specified as OPTS = 'UTN'.
!> \endverbatim
!>
!> \param[in] N1
!> \verbatim
!>          N1 is INTEGER
!> \endverbatim
!>
!> \param[in] N2
!> \verbatim
!>          N2 is INTEGER
!> \endverbatim
!>
!> \param[in] N3
!> \verbatim
!>          N3 is INTEGER
!> \endverbatim
!>
!> \param[in] N4
!> \verbatim
!>          N4 is INTEGER
!>          Problem dimensions for the subroutine NAME; these may not all
!>          be required.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2019
!
!> \ingroup OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The following conventions have been used when calling ILAENV from the
!>  LAPACK routines:
!>  1)  OPTS is a concatenation of all of the character options to
!>      subroutine NAME, in the same order that they appear in the
!>      argument list for NAME, even if they are not used in determining
!>      the value of the parameter specified by ISPEC.
!>  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
!>      that they appear in the argument list for NAME.  N1 is used
!>      first, N2 second, and so on, and unused problem dimensions are
!>      passed a value of -1.
!>  3)  The parameter value returned by ILAENV is checked for validity in
!>      the calling subroutine.  For example, ILAENV is used to retrieve
!>      the optimal blocksize for STRTRI as follows:
!>
!>      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
!>      IF( NB.LE.1 ) NB = MAX( 1, N )
!> \endverbatim
!>
!  =====================================================================
      INTEGER FUNCTION ILAENV(Ispec,Name,Opts,N1,N2,N3,N4)
      IMPLICIT NONE
!*--ILAENV166
!
!  -- LAPACK auxiliary routine (version 3.9.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2019
!
!     .. Scalar Arguments ..
      CHARACTER*(*) Name , Opts
      INTEGER Ispec , N1 , N2 , N3 , N4
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , ic , iz , nb , nbmin , nx
      LOGICAL cname , sname , twostage
      CHARACTER c1*1 , c2*2 , c4*2 , c3*3 , subnam*16
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC CHAR , ICHAR , INT , MIN , REAL
!     ..
!     .. External Functions ..
      INTEGER IEEECK , IPARMQ , IPARAM2STAGE
      EXTERNAL IEEECK , IPARMQ , IPARAM2STAGE
!     ..
!     .. Executable Statements ..
!
      IF ( Ispec==1 .OR. Ispec==2 .OR. Ispec==3 ) THEN
!
!
!     Convert NAME to upper case if the first character is lower case.
!
         ILAENV = 1
         subnam = Name
         ic = ICHAR(subnam(1:1))
         iz = ICHAR('Z')
         IF ( iz==90 .OR. iz==122 ) THEN
!
!        ASCII character set
!
            IF ( ic>=97 .AND. ic<=122 ) THEN
               subnam(1:1) = CHAR(ic-32)
               DO i = 2 , 6
                  ic = ICHAR(subnam(i:i))
                  IF ( ic>=97 .AND. ic<=122 ) subnam(i:i) = CHAR(ic-32)
               ENDDO
            ENDIF
!
         ELSEIF ( iz==233 .OR. iz==169 ) THEN
!
!        EBCDIC character set
!
            IF ( (ic>=129 .AND. ic<=137) .OR. (ic>=145 .AND. ic<=153)   &
     &           .OR. (ic>=162 .AND. ic<=169) ) THEN
               subnam(1:1) = CHAR(ic+64)
               DO i = 2 , 6
                  ic = ICHAR(subnam(i:i))
                  IF ( (ic>=129 .AND. ic<=137) .OR.                     &
     &                 (ic>=145 .AND. ic<=153) .OR.                     &
     &                 (ic>=162 .AND. ic<=169) ) subnam(i:i)            &
     &                 = CHAR(ic+64)
               ENDDO
            ENDIF
!
         ELSEIF ( iz==218 .OR. iz==250 ) THEN
!
!        Prime machines:  ASCII+128
!
            IF ( ic>=225 .AND. ic<=250 ) THEN
               subnam(1:1) = CHAR(ic-32)
               DO i = 2 , 6
                  ic = ICHAR(subnam(i:i))
                  IF ( ic>=225 .AND. ic<=250 ) subnam(i:i) = CHAR(ic-32)
               ENDDO
            ENDIF
         ENDIF
!
         c1 = subnam(1:1)
         sname = c1=='S' .OR. c1=='D'
         cname = c1=='C' .OR. c1=='Z'
         IF ( .NOT.(cname .OR. sname) ) RETURN
         c2 = subnam(2:3)
         c3 = subnam(4:6)
         c4 = c3(2:3)
         twostage = LEN(subnam)>=11 .AND. subnam(11:11)=='2'
!
         IF ( Ispec==2 ) THEN
!
!
!     ISPEC = 2:  minimum block size
!
            nbmin = 2
            IF ( c2=='GE' ) THEN
               IF ( c3=='QRF' .OR. c3=='RQF' .OR. c3=='LQF' .OR.        &
     &              c3=='QLF' ) THEN
                  IF ( sname ) THEN
                     nbmin = 2
                  ELSE
                     nbmin = 2
                  ENDIF
               ELSEIF ( c3=='HRD' ) THEN
                  IF ( sname ) THEN
                     nbmin = 2
                  ELSE
                     nbmin = 2
                  ENDIF
               ELSEIF ( c3=='BRD' ) THEN
                  IF ( sname ) THEN
                     nbmin = 2
                  ELSE
                     nbmin = 2
                  ENDIF
               ELSEIF ( c3=='TRI' ) THEN
                  IF ( sname ) THEN
                     nbmin = 2
                  ELSE
                     nbmin = 2
                  ENDIF
               ENDIF
            ELSEIF ( c2=='SY' ) THEN
               IF ( c3=='TRF' ) THEN
                  IF ( sname ) THEN
                     nbmin = 8
                  ELSE
                     nbmin = 8
                  ENDIF
               ELSEIF ( sname .AND. c3=='TRD' ) THEN
                  nbmin = 2
               ENDIF
            ELSEIF ( cname .AND. c2=='HE' ) THEN
               IF ( c3=='TRD' ) nbmin = 2
            ELSEIF ( sname .AND. c2=='OR' ) THEN
               IF ( c3(1:1)=='G' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nbmin = 2
               ELSEIF ( c3(1:1)=='M' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nbmin = 2
               ENDIF
            ELSEIF ( cname .AND. c2=='UN' ) THEN
               IF ( c3(1:1)=='G' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nbmin = 2
               ELSEIF ( c3(1:1)=='M' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nbmin = 2
               ENDIF
            ELSEIF ( c2=='GG' ) THEN
               nbmin = 2
               IF ( c3=='HD3' ) nbmin = 2
            ENDIF
            ILAENV = nbmin
            RETURN
         ELSEIF ( Ispec==3 ) THEN
!
!
!     ISPEC = 3:  crossover point
!
            nx = 0
            IF ( c2=='GE' ) THEN
               IF ( c3=='QRF' .OR. c3=='RQF' .OR. c3=='LQF' .OR.        &
     &              c3=='QLF' ) THEN
                  IF ( sname ) THEN
                     nx = 128
                  ELSE
                     nx = 128
                  ENDIF
               ELSEIF ( c3=='HRD' ) THEN
                  IF ( sname ) THEN
                     nx = 128
                  ELSE
                     nx = 128
                  ENDIF
               ELSEIF ( c3=='BRD' ) THEN
                  IF ( sname ) THEN
                     nx = 128
                  ELSE
                     nx = 128
                  ENDIF
               ENDIF
            ELSEIF ( c2=='SY' ) THEN
               IF ( sname .AND. c3=='TRD' ) nx = 32
            ELSEIF ( cname .AND. c2=='HE' ) THEN
               IF ( c3=='TRD' ) nx = 32
            ELSEIF ( sname .AND. c2=='OR' ) THEN
               IF ( c3(1:1)=='G' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nx = 128
               ENDIF
            ELSEIF ( cname .AND. c2=='UN' ) THEN
               IF ( c3(1:1)=='G' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nx = 128
               ENDIF
            ELSEIF ( c2=='GG' ) THEN
               nx = 128
               IF ( c3=='HD3' ) nx = 128
            ENDIF
            ILAENV = nx
            RETURN
         ELSE
!
!
!     ISPEC = 1:  block size
!
!     In these examples, separate code is provided for setting NB for
!     real and complex.  We assume that NB will take the same value in
!     single or double precision.
!
            nb = 1
!
            IF ( subnam(2:6)=='LAORH' ) THEN
!
!        This is for *LAORHR_GETRFNP routine
!
               IF ( sname ) THEN
                  nb = 32
               ELSE
                  nb = 32
               ENDIF
            ELSEIF ( c2=='GE' ) THEN
               IF ( c3=='TRF' ) THEN
                  IF ( sname ) THEN
                     nb = 64
                  ELSE
                     nb = 64
                  ENDIF
               ELSEIF ( c3=='QRF' .OR. c3=='RQF' .OR. c3=='LQF' .OR.    &
     &                  c3=='QLF' ) THEN
                  IF ( sname ) THEN
                     nb = 32
                  ELSE
                     nb = 32
                  ENDIF
               ELSEIF ( c3=='QR ' ) THEN
                  IF ( N3==1 ) THEN
                     IF ( sname ) THEN
!     M*N
                        IF ( (N1*N2<=131072) .OR. (N1<=8192) ) THEN
                           nb = N1
                        ELSE
                           nb = 32768/N2
                        ENDIF
                     ELSEIF ( (N1*N2<=131072) .OR. (N1<=8192) ) THEN
                        nb = N1
                     ELSE
                        nb = 32768/N2
                     ENDIF
                  ELSEIF ( sname ) THEN
                     nb = 1
                  ELSE
                     nb = 1
                  ENDIF
               ELSEIF ( c3=='LQ ' ) THEN
                  IF ( N3==2 ) THEN
                     IF ( sname ) THEN
!     M*N
                        IF ( (N1*N2<=131072) .OR. (N1<=8192) ) THEN
                           nb = N1
                        ELSE
                           nb = 32768/N2
                        ENDIF
                     ELSEIF ( (N1*N2<=131072) .OR. (N1<=8192) ) THEN
                        nb = N1
                     ELSE
                        nb = 32768/N2
                     ENDIF
                  ELSEIF ( sname ) THEN
                     nb = 1
                  ELSE
                     nb = 1
                  ENDIF
               ELSEIF ( c3=='HRD' ) THEN
                  IF ( sname ) THEN
                     nb = 32
                  ELSE
                     nb = 32
                  ENDIF
               ELSEIF ( c3=='BRD' ) THEN
                  IF ( sname ) THEN
                     nb = 32
                  ELSE
                     nb = 32
                  ENDIF
               ELSEIF ( c3=='TRI' ) THEN
                  IF ( sname ) THEN
                     nb = 64
                  ELSE
                     nb = 64
                  ENDIF
               ENDIF
            ELSEIF ( c2=='PO' ) THEN
               IF ( c3=='TRF' ) THEN
                  IF ( sname ) THEN
                     nb = 64
                  ELSE
                     nb = 64
                  ENDIF
               ENDIF
            ELSEIF ( c2=='SY' ) THEN
               IF ( c3=='TRF' ) THEN
                  IF ( sname ) THEN
                     IF ( twostage ) THEN
                        nb = 192
                     ELSE
                        nb = 64
                     ENDIF
                  ELSEIF ( twostage ) THEN
                     nb = 192
                  ELSE
                     nb = 64
                  ENDIF
               ELSEIF ( sname .AND. c3=='TRD' ) THEN
                  nb = 32
               ELSEIF ( sname .AND. c3=='GST' ) THEN
                  nb = 64
               ENDIF
            ELSEIF ( cname .AND. c2=='HE' ) THEN
               IF ( c3=='TRF' ) THEN
                  IF ( twostage ) THEN
                     nb = 192
                  ELSE
                     nb = 64
                  ENDIF
               ELSEIF ( c3=='TRD' ) THEN
                  nb = 32
               ELSEIF ( c3=='GST' ) THEN
                  nb = 64
               ENDIF
            ELSEIF ( sname .AND. c2=='OR' ) THEN
               IF ( c3(1:1)=='G' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nb = 32
               ELSEIF ( c3(1:1)=='M' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nb = 32
               ENDIF
            ELSEIF ( cname .AND. c2=='UN' ) THEN
               IF ( c3(1:1)=='G' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nb = 32
               ELSEIF ( c3(1:1)=='M' ) THEN
                  IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR.        &
     &                 c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR.        &
     &                 c4=='BR' ) nb = 32
               ENDIF
            ELSEIF ( c2=='GB' ) THEN
               IF ( c3=='TRF' ) THEN
                  IF ( sname ) THEN
                     IF ( N4<=64 ) THEN
                        nb = 1
                     ELSE
                        nb = 32
                     ENDIF
                  ELSEIF ( N4<=64 ) THEN
                     nb = 1
                  ELSE
                     nb = 32
                  ENDIF
               ENDIF
            ELSEIF ( c2=='PB' ) THEN
               IF ( c3=='TRF' ) THEN
                  IF ( sname ) THEN
                     IF ( N2<=64 ) THEN
                        nb = 1
                     ELSE
                        nb = 32
                     ENDIF
                  ELSEIF ( N2<=64 ) THEN
                     nb = 1
                  ELSE
                     nb = 32
                  ENDIF
               ENDIF
            ELSEIF ( c2=='TR' ) THEN
               IF ( c3=='TRI' ) THEN
                  IF ( sname ) THEN
                     nb = 64
                  ELSE
                     nb = 64
                  ENDIF
               ELSEIF ( c3=='EVC' ) THEN
                  IF ( sname ) THEN
                     nb = 64
                  ELSE
                     nb = 64
                  ENDIF
               ENDIF
            ELSEIF ( c2=='LA' ) THEN
               IF ( c3=='UUM' ) THEN
                  IF ( sname ) THEN
                     nb = 64
                  ELSE
                     nb = 64
                  ENDIF
               ENDIF
            ELSEIF ( sname .AND. c2=='ST' ) THEN
               IF ( c3=='EBZ' ) nb = 1
            ELSEIF ( c2=='GG' ) THEN
               nb = 32
               IF ( c3=='HD3' ) THEN
                  IF ( sname ) THEN
                     nb = 32
                  ELSE
                     nb = 32
                  ENDIF
               ENDIF
            ENDIF
            ILAENV = nb
            RETURN
         ENDIF
      ELSEIF ( Ispec==4 ) THEN
!
!
!     ISPEC = 4:  number of shifts (used by xHSEQR)
!
         ILAENV = 6
         RETURN
      ELSEIF ( Ispec==5 ) THEN
!
!
!     ISPEC = 5:  minimum column dimension (not used)
!
         ILAENV = 2
         RETURN
      ELSEIF ( Ispec==6 ) THEN
!
!
!     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
!
         ILAENV = INT(REAL(MIN(N1,N2))*1.6E0)
         RETURN
      ELSEIF ( Ispec==7 ) THEN
!
!
!     ISPEC = 7:  number of processors (not used)
!
         ILAENV = 1
         RETURN
      ELSEIF ( Ispec==8 ) THEN
!
!
!     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
!
         ILAENV = 50
         RETURN
      ELSEIF ( Ispec==9 ) THEN
!
!
!     ISPEC = 9:  maximum size of the subproblems at the bottom of the
!                 computation tree in the divide-and-conquer algorithm
!                 (used by xGELSD and xGESDD)
!
         ILAENV = 25
         RETURN
      ELSEIF ( Ispec==10 ) THEN
!
!
!     ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap
!
!     ILAENV = 0
         ILAENV = 1
         IF ( ILAENV==1 ) ILAENV = IEEECK(1,0.0,1.0)
         RETURN
      ELSEIF ( Ispec==11 ) THEN
!
!
!     ISPEC = 11: ieee infinity arithmetic can be trusted not to trap
!
!     ILAENV = 0
         ILAENV = 1
         IF ( ILAENV==1 ) ILAENV = IEEECK(0,0.0,1.0)
         RETURN
      ELSEIF ( Ispec==12 .OR. Ispec==13 .OR. Ispec==14 .OR.             &
     &         Ispec==15 .OR. Ispec==16 ) THEN
!
!
!     12 <= ISPEC <= 16: xHSEQR or related subroutines.
!
         ILAENV = IPARMQ(Ispec,Name,Opts,N1,N2,N3,N4)
         GOTO 99999
      ENDIF
!
!     Invalid value for ISPEC
!
      ILAENV = -1
      RETURN
!
!     End of ILAENV
!
99999 END FUNCTION ILAENV


submodule(forlab_time) forlab_time_tioc

    use stdlib_strings, only: to_string
    implicit none
    real(dp), save :: tic_time

contains
    module procedure tic
    integer :: values(8)
    call date_and_time(values=values)
    tic_time = datenum(values(1), values(2), values(3), values(5), &
                       values(6), values(7), values(8)*1000) &
               *24.0d0*60.0d0*60.0d0
    return
    end procedure tic

    module procedure toc_default
    integer :: values(8)
    real(dp) :: toc_time, elapsed_time

    call date_and_time(values=values)
    toc_time = datenum(values(1), values(2), values(3), values(5), &
                       values(6), values(7), values(8)*1000) &
               *24.0d0*60.0d0*60.0d0
    elapsed_time = toc_time - tic_time

    call disp("Elapsed time: " &
              //to_string(elapsed_time, "(F12.3)") &
              //" seconds")
    return
    end procedure toc_default

    module procedure toc_sp
    integer :: values(8)
    real(dp) :: toc_time, elapsed_time

    call date_and_time(values=values)
    toc_time = datenum(values(1), values(2), values(3), values(5), &
                       values(6), values(7), values(8)*1000) &
               *24.0d0*60.0d0*60.0d0
    elapsed_time = toc_time - tic_time

    time = elapsed_time        !!\ATTENTION@zuo.zhihua@qq.com: Accuracy is converted here.
    return
    end procedure toc_sp
    module procedure toc_dp
    integer :: values(8)
    real(dp) :: toc_time, elapsed_time

    call date_and_time(values=values)
    toc_time = datenum(values(1), values(2), values(3), values(5), &
                       values(6), values(7), values(8)*1000) &
               *24.0d0*60.0d0*60.0d0
    elapsed_time = toc_time - tic_time

    time = elapsed_time        !!\ATTENTION@zuo.zhihua@qq.com: Accuracy is converted here.
    return
    end procedure toc_dp

end submodule forlab_time_tioc


text:
Losing a pet is a horrible thing. This page is meant to help people get a start on finding their beloved pet! Or, if youve found someone elses pet, you can post here to try to reach an owner. Please remember to add dates to postings.

Due to the number of missing pets, those who have been missing for one year or longer may be moved to the Lost Pets/Archive Lost Pets Archive page.

In addition, it helps to be proactive! Dont let your pet outside unsupervised in the first place (especially rabbits, with the heat and predators and http://www.littlebigcat.com/health/indoorsoroutdoors/ read here why you shouldnt let your cat outside). Whether they are indoor or outdoor, you should have your pet implanted with a small microchip. Although you cannot track a missing pet with a microchip, a person will likely contact a local animal humane society, shelter, animal hospital, etc., and one of the first things they will do is scan the animal to see if theres a microchip implanted, which will have all the relevant information to return your pet to you! This costs only $45 (plus an office visit) at the Vet Med Teaching Hospital VMTH, and can be done by most veterinarians, and is highly recommended! Some people with indoor cats keep a breakaway collar on them just in case they slip out. It helps to engrave indoor cat along with contact information so whoever finds them knows they are lost rather than just wandering.

(scroll down for instructions on adding a pet)

 Found an Animal?

The Yolo County Animal Shelter provides care lost animals within the county.

Adding a Lost/Found Pet Listing to DavisWiki

Youll need to login, add your listing by editing the page, then preview and save your edit.

 1. New to DavisWiki? To add a listing youll need to sign up for a username. Its quick and easy...click on the new user link at the top of the page.
 2. After you login, click on Edit.
 3. Locate the {{{List of lost or found pets}}} heading in the editor window. There are some iunstructions there. In a nutshell:
 4. Add your listing below the heading. Its easiest to simply copy and edit one of the examples, or follow these steps:
   Add a title for your listing by placing double equals signs on either side. Examples:
  {{{ LOST DOG: mm/dd/yy. Snoopy. Beagle. White with black ears and black nose. }}}
  {{{ FOUND CAT: mm/dd/yy. All black with white paws }}}
   Add an image if possible. Look at the examples for how to place the images so they look nice. See Help with Images for more info. Examples:
  {{{ Image(snoopy1.jpg, thumbnail, 400, left) }}}
  {{{ Image(blackcatfound_jan7_2013.jpg, thumbnail, 400, left) }}}
   Add information about the pet below the image (or title if no image): a detailed description, where and when last seen (or found), your contact info, etc.
   Add separator lines, one line of four equal signs {{{}}} and one line of four minus signs {{{}}}. This keeps your entry visually separated from the next one.
 5. When your pet makes it home, be sure to come back and remove the listing or move it to Lost Pets/Success Stories Success Stories page!

What Else You Can Do

When you first lose (or find) a pet, here are some practical first steps you should take:

 1. Visit the Yolo County Animal Shelter (where your pet will likely end up if it is taken to the police, or if somebody finds it) in Woodland at 2640 E. Gibson Rd. It is open TuesdayFriday from 10am1pm and 26pm, and open Saturdays from 10am1pm and 24pm. They are closed Sundays and open for limited services (no adoptions) on Monday from 15PM. A shelter employee will have you file a lost report on your pet and walk you through the shelter to see if your pet is there. You may also file a lostreport at this location, please bring a printed photo if you can. Your lost report will be on file with the SPCA office there, and will be checked with every animal brought into the shelter. They  will also scan animals to check for microchips, so knowing your pets microchip number is handy, in addition to having the registration information up to date..
 2. Call the Yolo County http://www.yolospca.org/ SPCA at 5306628858 and provide a detailed description of your pet. If you have digital photos of your pet, you can email these to a SPCA representative to ycasrescue@hotmail.com
 3. Post fliers within at least 3block radius from your home or last seen location and talk to your neighbors directly.
 4. Call the Davis Police Department at their nonemergency number (530)7475400 (The people who found our dog called the Police Department).
 5. In addition to the Davis Wiki, post lost and found animals in the local https://www.facebook.com/groups/PetsLostAndFoundDavisCA/ facebook group. Members include YSPCA and UCD VMTH as well as several area vets and animal shelter employees. Please join https://www.facebook.com/groups/PetsLostAndFoundDavisCA/ this group and check it often so that it can be an effective community resource. You can also post ads in http://sacramento.craigslist.org/ Craigs List, http://www.davisenterprise.com/ Davis Enterprise, http://www.petfinder.com/ Petfinder and http://www.petharbor.com/ Pet Harbor.
 6. Post a flier at Petcos bulletin board and other pet stores, along with coffee shops and stories where people visit often (libraries, Target, schools, etc).
 7. If you lost a cat, realize that the cat may be hiding during the day due to all the commotion and dogs being walked outside. Go out at night when it is quiet and call your cats name. You may find that the cat has been hiding in the neighborhood nearby. They often dont go very far. There are excellent catfinding tips for a variety of cat personalities at http://www.catsinthebag.org Cats In The Bag.
 8. Call all of the veterinary clinics in Davis people bring and report found animals often.
 9. If you FOUND a pet, take it to a Veterinary Hospitals veterinarian to get it scanned for a microchip. File a found report with Animal Control. Post in the local https://www.facebook.com/groups/PetsLostAndFoundDavisCA/ facebook group.
10. If you cant care for it, take it to the Yolo County Animal Shelter or post in the local https://www.facebook.com/groups/PetsLostAndFoundDavisCA/ facebook group to see if anybody can foster for the time being.

GOOD LUCK everyone, and dont give up!!!

List of lost or found pets

##
## NEW WIKI USERS, READ THIS
##
## Please use the following consistent format when you add an entry. This will help keep this page wellorganized and make it so that your information is clear and easily readable by everyone else.
##
## The first line of your new entry should start with two equal signs (), followed by LOST or FOUND, the type of animal (DOG, CAT, RABBIT, etc.), a colon (:), the date animal was lost or found, a period (.), animals name in quotes (if you know it), a short description of the animal, and then  again. Please do not try to pack too much info into this first line.
## Next line, put a picture of the animal, left justified like so: Image(yourpicture.jpg, thumbnail, 400, left) (this is optional, and you can add it later)
## Subsequent line(s), more description about the circumstances, location, and contact info. The more information the better.
## Follow your entry with a line of four equal signs () AND a line of four minus signs ()
## Example:
##
## LOST CAT: 1/5/12. Snookums. Black and white tuxedo cat with faint stripes
## Image(snookums.jpg, thumbnail, 400, left)
## Name: Snookums. 4 years old. Lost in the vicinity of A St and 7th St, neutered male, has black collar with tags, microchipped, contact Dave Davisite (530) 4001234
##
##
##
## YOUR NEW ENTRY SHOULD GO RIGHT AFTER THIS LINE!  Please look at the Snookums example above.

FOUND CAT: 08/07/14. Medium/Long haired, Siamese/Tabby mix with blue eyes
Found in vicinity of Lake and Covell Blvd. Medium/Long haired light brown coat with stripes on front legs. Dark ears and between ears, dark, fluffy tail. Timid, skinny and hungry. Ran away this morning (8/9/14) when I tried to feed it but did eat and let me take photos last evening at a close distance. Contact me at 5307599728 or 5308484374

 FOUND CAT: 7/20/2014. Black and white, probably a neutered boy NOT microchipped
Found at dusk (around 8pm) 7/20/14 in the North Davis Green Belt right next to Jalisco. I think he is a neutered boy but I could be wrong, he is pretty fluffy so it was hard to tell. Sweet affectionate full grown cat, not very chatty. No extra toes, clearly a beloved pet that is now a little skinny and dirty. One arm is mostly white the other had a black patch near the elbow, black tail. I have many more pictures, email me if interested. (feycooper@ gmail .com) We thought he looked like Indiana (another missing cat) and when we returned him the owner said it was not Indiana. We took him to VetMed and they scanned him for a chip but found nothing, and he had no collar. We released him back where we found him with some food.

LOST DOG: 6/15/14. Wally. Schnauzer. Black.
Call 5307539768. Thank you.

FOUND DOG 4/3/14. Sam yellow lab
Microchipped. Found at pole line and covell around twelve thirty PM. No leash. Call at 5305543502

LOST CAT: 3/19/14. Victor. Male neutered orange and white tabby with extra toes.
He has a crook in his tail. He is 11 years old. Friendly. No collar. Last seen E.8th & K Sts. Contact Tanya 7076166795.

FOUND DOG: 3/18/14.  Female black and white wirehaired terrier mix
Approx 3 yrs old, found in vicinity of F St. and 6th St, no tags or chip, sweet dog, contact Kimberley 5302198200

FOUND DOG: 2/14/14. small, black with some white in chest
found in arroyo park, chihuahua/dachshund cross?, taken to Yolo Co animal shelter

FOUND DOG: 2/10/14. Brindle hound, male
Very friendly dog found at the park on Arroyo Ave & Alhambra Dr. Blue collar. Taken to Yolo County Animal Services, Woodland. Animal ID A122014

LOST DOG: 2/2/14. Marilyn. Beagle. Brown and White
Name: Marilyn. 5 years old. Lost in the Stonegate Lake area, spayed female, has purple collar with tags, microchipped, contact Mr. Tang (530) 2192795. Appreciate your helps!

SPOTTED SIX CATS: 1/10/14  1/14/2014.  Cat colony at east end of Arboretum
While biking the Davis Loop, I spotted these two cat friends, who were relaxing together in the sun. Are they wild, are they lost, are they at home around there? I dont know. But maybe somebody recognizes them as their own? It was at the end of the Arboretum towards Rocknasium. Its directly behind the new location of the Davis Flea Market. Come to think of it, on another point of the Davis bike loop, maybe a couple of weeks ago,  loop I saw a very sad, light haired cat, he was incredibly! lean, you saw all his bones :(, and exhausted. I didnt know what to do, as I dont want to catch a cat like that (we cant take a cat in our house). I mention this, because I think its very sad that people lose their cats like that. Because I bike a lot in Davis (about 4 5 times a week) I see cats without identification all the time and I think its better to keep them inside. Better for the birds as well. I think it should be enforced by law that all cats wear identification.

Tail piece 1/13/2014

Today when I biked by again, I saw the two cat friends again, now cozy socializing in the pipe, and a third, gray cat was joining them. Obviously these cats live here, so anybody looking for them, can find them here.

Tail Piece 2  1/14/2014

I biked by again and this time had my Canon with me. Unfortunately, no sharp photos again. Its like I thought, there are even more cats living there in a group. I took photos of 6 different ones (see all pics and compare closely) now. I suspect there even are more than six. I will keep an eye on them. These cats look good enough, but wear no identification and are very on their guard. Who knows if they belong to somebody?

 Users/ConstantiaOomen CO
 There have been feral cats living there for ever and a day, they want nothing to do with humans. totally feral. Some of them have punched ears, others dont. The kittens have gotten bigger as well, they are almost cats now. Daubert ~SD

 @ SD: Ah, so you knew abut this place? But what about the all grey cat (pic 2, 5 and 6) and the very big cat (in pic 3); could it be that they have joined the group? I see two cats in the Lost section with the names Nugget and Belchik, and it could well be them?  Users/ConstantiaOomen CO

FOUND CAT: 1/9/14. Short hair blond/light light orange
I found this cat Friday morning in my yard.I live off of Lake, near Covell Blvd.  I saw him again Saturday and Sunday. He has probably been on his own for a bit since he is a bit dirty and skinny. He is very friendly and wants to come inside. He enjoys being petted. He has beautiful blue eyes and is not neutered. Would love to find his home. For more details, call (530) 7599728.

FOUND CAT: 1/1/14. Long hair black and white
I found this cat while looking for my own lost cat. Its living in the bushes near the Teichert facility at Road 29 & Sycamore. I tried to catch it, but it bolted when I tried to get it into the carrier. Seems healthy and not too many mats in its long hair, which makes me think it hasnt been out there very long. Friendly and approachable. For more details call (530) 7468741

LOST CAT: 12/6/13. Destiny. Female, Mixed colored brown, tan, orange, and white.
Lost in Woodland, CA on McKinley Avenue between Cypress Dr. And Cedar Lane. She is missed very much and like my daughter and best friend. All Im asking and want is for her to come home safely. If anyone knows anything please contact me (530) 6612441 Or missyvincent530@gmail.com

FOUND CAT: 12/13/13. Black and White with distinctive black nose
Corner of J and Alice St. Contact me at soso.sonia@gmail.com if this is your cat.

This very sweet black and white female  cat has been hanging around our house for a couple of weeks now. At first we thought she was the neighbors but she has no collar. Contact me if she is yours.

LOST CAT: 11/22/13. Tuxedo Cat
Updated 2/13/14. Cat missing from Nov 22. Last seen in parking lot of Davis Christian Assembly Church (at Sycamore). Three women in their 20s were seen by a neighbor trying to catch him, and then he was gone the next day. They were driving a white SUV wagon. Maybe they thought he was a stray. The cat is black and white, all white legs and feet. Polydactyly (has extra toes). Small section of hair on allblack tail missing from a previous injury. Green eyes. Called a tuxedo cat because of Vshaped section of white hair on chest and belly. Please call (530) 7468741 with any information.

FOUND CAT: 11/23/13. Older male cat, SOO sweet.
Extremely sweet male cat found outside around 14th street and Anderson. Super skinny, fur and bones looks like hes been lost for a while but hes the sweetest cat Ive ever seen so I know hes had great owners and they may have lost him a while ago. Hes been to the vet, well taken care of past couple days but no microchip. Hopefully owners havent given up on him but otherwise hes in great hands. email me at ackerstens@ucdavis.edu I check my email all day everyday! If you think it could be yours please also send me an email or check craigslist because it would upload my picture on here, I think he is a Tabby?

FOUND CAT: 11/22/13. Tortoiseshell cat.
Friendly tortoiseshell cat has been hanging around Putah Creek Stable on Old Davis Rd. for quite a few weeks. She is very sweet...but we already have 7 barn cats and cant take another.  If this is your kitty, please contact me at 8475071326 or at karenleighbaker@att.net.  We have her in a big crate in our tack room.

LOST DOG: 11/20/13. Booger. Pit bull. White with brown patches and a dark brown nose.
Name: Booger. Almost 3 years old, neutered, ~50lbs and collarless. He went missing around Drake Drive early in September. Please call/text me anytime @ 530 400 117eight or email @jjudychu@gmail.com if you see him.

LOST BUNNIES: 11/16/13. White with black ears/nose, dark grey with black ears/nose.
Lost near Slide Hill Park. Please contact Corrie at 530574544nine! (Text or call.)

FOUND CAT: 11/16/13. Orange and White. Very Skinny and Looks very young
Name: Unknown. Looks very young. Found at 3rd and K. Have been feeding the cat, and cat is very loving. Please call me any time at 7072918124 if you think this your cat. I am not allowed to have pets in my apartment and will be forced to take the cat to the pound on on Monday 11/18/2013.

FOUND DOG: 11/12/13. Border Collie
We found a young Border Collie near Russell Boulevard and County Road 97.  If this is your dog please call 530 400 7343.

FOUND RABBIT: 11/6/13. Grey & white
F and Covell. Very friendly please call 5308485413

FOUND CAT: 10/29/13. All Black
This cat gradually started showing up at our house downtown by central park and then staying longer and longer. It now seems to stay all day. Very comfortable around people and friendly. Appears to be middle aged. If you think this is your cat give me a call at (510) 9152731

SEEN CAT: 10/23/13. Light Grey cat without Tags or Collar
The cat disappeared before I could take a picture of it, I saw it in the Northern Parking Lot of the Colleges at La Rue, closer to the main curb than the back area of the parking lot.  Seemed to shy away from human contact and hid and/or ran before I could get my phone out to take a picture of it.  Seen at 11:00 AM. Call (818) 8255879 if this is your cat and I can direct you to where the cat was last seen.

FOUND DOG: 9/30/10.
Found around 6:45pm running on 5th street towards Lake Alhambra Estates
Young, friendly dog. Very clean, well cared for, and playful. No collar or tags. We will take to a vet on Oct. 1 for micro chip scanning.
email: wendymn@gene.com or text/call 7076855801

SEEN DOG: 9/2728/13. Black and white collie
Seen at the corner of Portage Bay East and Hudson. Black and white seeminglycollie wandering around into peoples yards at midnight. Wasnt able to get close enough to get dog tags, possibly because I had a bike at the time. Looked clean and healthy. Hope whoevers he/she is finds them.

LOST DOG: 9/21/2013. Calliope. Light brindle dog with pink collar
Medium female light brindle dog with pink collar and red bone nametag got out of backyard on Saturday near Community park. She is my daughters dog. My daughter recently past away and we really want her dog back. Please if you have any information let us know loralschroeder@gmail.com or 5304000503.

FOUND CAT: 9/20/13. Chubby Tabby Cat
The cat is wandering around the Ramble Apartments. She or he has a collar but no tags. She is creamed colored, has yellow eyes, and a little on the chubby side. She is following everyone who walks pass her and runs after them when they walk away from her. She is SUPER friendly. MY HEART IS BROKEN FOR HER! You can contact me at mhnngo@ucdavis.edu but she wondered off into the other buildings now.

LOST CAT: 9/15/13. Juniper. Small female cat, black and white (with a black moustache), very shy, easily scared.  Very sweet.
Juniper disappeared on Saturday during a move.  She got scared and took off.  I heard she might have been seen in apartments near SaveMart on Tuesday (9/17).  She will probably come if you call her name, but shes skittish and might not let strangers touch her.  Please let me know if you spot her! Thank you! laurelr@hotmail.com, 5302190963.

SEEN DOG: 9/3/13 and 9/4/13.
Small, White dog, unsure of breed, floppy ears. Ran and barked when I got near it. Saw him/her in the evening and then again this morning as I was leaving for work. In the CuldeSac of the south entrance to Greene Terrace (South Davis across from Playfields Park). Unfortunately I am unable to keep the dog at my home until the owner claims him. Email Erica.pietryka@gmail.com for information.

FOUND DOG: 9/2/13. Black Lab
Found this dog wandering near Miller + B. About 80 lbs, all black, neutered. Mellow. Wearing red collar and training chain but no tags. Contact noam.ross@gmail.com.

SEEN CAT: 9/1/13. Tiger with white patches.
Is this your cat? He/she was first noticed near the UCD Physics Dept about 1 week ago. Seen at east corner of building close to parking lot and Mrak Hall. Very skittish. Gets food and water along with 3 longterm residents of feral cat colony. Email richthand@gmail.com for further information.

LOST CAT: 8/29/13. Thai.  All black with white pooch and hind toes
lost him near J st and Cranbrook Ct. Thai is fixed and chipped. All black with a white pooch and white hind toes.
Call or text James 5304004610 (24/7)

FOUND CAT: 8/19/13. Calico with litter of kittens!
Has been seen around house in NE Woodland for the past 2 weeks. DSH, small, young adult. Today brought out litter of 4, 12 week old kittens. Very friendly & eager for attention, seems clear she has been in a home at some point in her life. No collar or microchip. Mom & babies are currently in a home in Davis to protect from heat, will stay until we either find her family or babies are weaned & in new homes. There is another cat, DSH grey/white, very feral, seen with her. Email Cheri@pobox.com.

FOUND DOG: 8/18/13. Whitish, small (<10 lbs)
Straightish hair (sorry, I dont know breeds, maybe a shih tzu???). Very happy, welltrained and tagless. Found at the corner of Russell and Arthur in the middle of the road without anyone around. Email me: lopresti.eric@gmail.com

LOST CAT: 8/14/13. Pachayo (Packeeoh). Black Domestic Shorthair Female Cat
Pachayo was last seen around August 14 at Slatters Court, near Olive Drive and Richards Blvd. She is all black except for a small white patch on her chest. She has yellow eyes. She is very friendly and will likely approach people to solicit attention. She likes to roam, and we assume that someone has who was feeding her has now taken her in. We love her very much and want to see her and know she is safe! Please call or text (760) 9142963 or email rennieputnam@gmail.com with any information. Thanks.

Update: Still missing as of 8/30/13.

FOUND DOG: 8/12/13. Gray Shih Tzu
Found around 6:30PM in front my apartment at Sycamore Lane Apartment on Anderson Road. He is a gray Shih Tzu and he has no tags. Email me at cjbronec@ucdavis.edu or 4085101995.

SEEN DOG 8/02/13 9:30pm
Driving home we saw a white dog with fluffy ears and a red collar running down Simmons Way from 8th Street. We pulled over to catch her and read her tag but the dog disappeared into the bushes and even though we searched we could not find the dog. Email me for more details dncooper@ucdavis.edu.

FOUND CAT: 7/31/13. Plump Tabby Female Cat.
Image(Found cat 7.31.2013 (2).jpg, thumbnail, 400, right)Found wondering around University Village Apartments in East Davis. Very sweet and friendly. Please contact Samantha at s.nakagaki@yahoo.com.

LOST CAT: 7/15/13. Baby or Baby Mouse. Domestic Shorthair Female Cat
Still missing as of 8/14/13.

Baby was last seen at the Domino Park at the end of Valencia Ave in North Davis. Last time she was missing she was found over by the tennis courts near Grande Ave by the bike path. Baby has an attitude and might be nice to you or grumpy depending on her mood. She has loose skin under her belly that flops around when she runs. She is curious and could walk into your garage or home. She has been gone a month and could honestly be anywhere by now. She has a micro chip and we have ads up in the Davis Enterprise and on Craigslist. Please call John (9167186804 or Lina (9167186930). REWARD!! Please either snatch her up if you see her or call us. Thanks

LOST CAT: 7/15/13. Billie. 7year old female, small, tortie point siamese with white blaze on forehead.

She is easily scared, but a talker when comfortable.

Home is North Davis near Hermosa and the Greenbelt. Last seen 7/11/13. Please call 5307582204 or email richthand@gmail.com if youve seen her.

Update: STILL MISSING: 8/22/13.

LOST CAT: 7/15/13. Thorlo. 3year old male, tuxedo black body with white belly, chin, nose and four white feet.
His tail is short (about half the normal size).

Cat missing from North Davis, Covell Commons on 7/12/13. Please call 8052459761

LOST CAT: 7/9/13. Nugget. 11 months old, brown and black tabby with golden eyes, male
Cat missing from South Davis, July 9, for over 48 hours. Please call (530)9024435 or (530)5206207

LOST CAT: 7/3/13. Bean. 14yearold, calico, female
Cat missing from North Davis, July 2, for over 24 hours. Please email bettypat345@yahoo.com if you have any info!

FOUND Turtle: 6/24/13. Small(4 long,) olive green with box like markings on shell
Was found in front of our house on Faro Ave in North Davis. If you think this is your turtle please email me at megconant@hotmail.com.

FOUND DOG: 6/21/13. Small Brown Dachshund/Mix
Was found in front of our house on Frontera Drive in East Davis. She seems young with no tags and no microchip. She is wearing a collar. If you think this is your dog please email me at nickerson714@aol.com.

LOST CAT: 6/19/13. Pierre. Large, black short hair, with 3 white hairs on chest.
Pierre was last seen near Portage Bay West and Lake Blvd. He escaped from Sone Gate Village, next door to Arlington Farms Apts. Pierre is black with green eyes, an indoor cat, and does not wear a collar. He is very long (30in) and weights about 15 LBS. He has a very loud meow and a brown freckle on the green iris of his left eye. If you have seen him please call Jenn at 3103097736. Thank you so much.

LOST CAT: 6/17/2013. Pudge. Thick fur; tan; chocolate brown legs, tail, face, and ears; blue eyes.
Lost near the intersection of Sycamore and Quail streets. He may have wandered onto the greenbelt. He has no collar (he takes them off). His microchip# is 981020003764040. Pudge has a potentially fatal medical condition that needs treatment, so we need to find him soon. Call 5309021163.

FOUND DOG: 6/9/13. Male shepherd mix
8th and college park this morning at 9am, running in traffic. shaved recently. if someone from the neighborhood who is set up for dogs could take him until an owner appears, I would appreciate it. I have had him since 9am and am not equipped for keeping him. If you are the owner, or can foster him, please respond to the ad on craigslist: http://sacramento.craigslist.org/pet/3860273203.html

FOUND DOG: 5/31/13. white small dog
Lost dog in North Davis! If you or anyone you know lost him please contact me. He has a flea collar but thats it. Im taking him tomorrow to the Cat Clinic to see if he has a microchip though
If you lost or know the owners, call (626)3794290

LOST DOG: 5/23/13. Cali. Female brindal pitbull puppy
Cali went missing today by Birch Lane Elementary School (southeast of Covell & Poleline). She has no tags or microchip.

If you find her, call (530) 4025712 or (530) 3123718

LOST DOG: 5/23/15. Small black chihuahua
Found this dog on the greenbelt, but escaped from our fence. Wearing tags with Sacramento number. Name: Hercules (on tags). Young and sweet, but ran too fast for me:( Last seen running towards L Street from East Davis. Headed downtown. Please call Stacia at 5305748186 if you have seen/captured him.

FOUND CAT:05/15/13. Young, Light orange & white, male tabby
Found in south Davis near Research Park Drive. Taken to vet: no microchip found. Loud & frequent purring. Very friendly. Obviously socialized with humans. A tad timid. Thinner build. Appears to be ~1year old, but his molars are offwhite indicating he may be a few years young. Please call Pari at 9256991539.

LOST CAT: 5/5/13. Isis Female Spayed 20 year DSH, thin, Black with white paw tips and under chin
She went missing 5/5/13 around 8:30pm in Woodland west side cross streets Northwood Dr and West. No collar. Microchipped. VERY friendly. Thin. Please call Liz at 5109324002 if found or have seen since missing. $200 Reward if found. Thank you.

LOST CAT: 5/5/13. Belchik. Neutered, 1 yearold Russian Blue cat, all grey with green eyes.
He went missing between 5/4/2013 and 5/5/2013 near the intersection of 7th and F Sts., downtown Davis. Please contact David Jefferson at (717) 5747377 or return to 614 7th St. There is a $50.00 cash reward if you find him. Thank you.

FOUND DOG: 4/29/13. Female Australian Shepard.
Found on Villanova Drive and Lemon Lane in Davis. She is wearing a purple paisley collar with no tags. She is very friendly. Text (or call but better to text) 5302204579.

LOST CAT: 4/20/13. Niner grey tabby, 8TH AND J ST
My cat has been missing since a few days after picnic day in Davis (4/20/13), his name is niner and he is VERY FRIENDLY. He likes to take off his collar and likes to be outdoor/indoor. Please, he has been missing for a while from COLLEGE SQUARE APTS, but I am not giving up. If you are feeding him PLEASE STOP AND GIVE HIM BACK. He is light grey/tabby with a tear on one ear. If you have even seen him please let me know, ANY INFO HELPS! please email mmenbari@gmail.com

FOUND BIRD: 4/18/13. Small light blue parakeet (not sure actually, what kind of bird)
Extremely well socialized, small, light blue, parakeet was found today at the Hickey Pool on the UC Davis campus. Not sure of the sex, but it has an ankle bracelet. I will post a picture tomorrow. Ive also reported the bird found to the police department and will try to drop it off at the Yolo County Animal Shelter tomorrow or Monday. If you can give me the # on the ankle bracelet, I will gladly return this bird to you. My number is (650)7145061.

LOST CAT: 4/13/13. 1 yr old Male Maine Coon mix
My indoor only cat went missing and has yet to turn up. He is a maine coon mix with medium/long greyish/brown hair. He has 4 white feet and a white underbelly, and is also missing one of his front teeth. Please let me know is you have any info about where he might be!!! Call/text 8188231275. Last seen in west davis around Lake and Portage Bay West. My boyfriend and I are desperate to get him back and are offering a reward for his return.

LOST CAT: 3/28/13. Red. Orange Neutered Male Tabby
Last seen in Wildhorse area, Davis, cross streets Nevelson Court and Moore St
Name is Red, 13 yrs old, about 12 lbs
No collar, but microchipped  # 464F130714
Beloved family pet.
If you find him, please call 9168123371. Thank you.

FOUND CAT: 3/30/13 Male Grey Tabby, distinct markings, not neutered
Found at the Arboretum on campus around 6:30pm, very friendly large cat. Please contact me if you are missing a cat matching this description! Call/text 4252445107.

FOUND DOG: 3/29/13 Female dachshund/pug cross?, beige with black face, etc.
Found in South Davis running with another mix in reddish color (couldnt catch her companion). Call 9168063141.

LOST DOG: 3/24/13. Hunter. Golden Lab
Lost in Mace Ranch. Call 5303706643. Watching him for a friend so tags are from Sacramento

FOUND BUNNY: 2/15/13 DWARF HOTOT
Very friendly, all white. Found in Pirate Park in Mace Ranch
Please call 8475071326 to claim

LOST DOG: 1/27/13. Wally. Male mini schnauzer, blackish gray
Names is Wally. Lives in East Davis. Call 7539768.

FOUND CAT:01/15/13. Young/kitten female? calico
Image(Stray kitten resized.jpg,thumbnail,400,left)I am 99% sure this is a girl, she looks pretty dirty right now, kind of skinny, I had to sit for a while before she would let me pet her, talkative, very sweet though. When I tried to pick her up she jumped out of my arms and now she wont let me get that close. No collar. Put out some food for her, she was very hungry and scared. This was in the Lexington apartment complex near campus and InNOut. Please call/txt (949)4562479 if this could be your cat! Sorry picture is so bad, I was going to take her inside and now I cant get too close so this is the best I could manage.

Comments are on their Lost Pets/Comments own page, theres also a Lost Pets/Talk Talk Page

## Do not add new entries down here. Add them at the top of the List of lost or found pets!
## Good Luck!

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text: #redirect wiki:Sacramento:DoorMart Garage Doors


text:
      SUBROUTINE SETSHLD(TSC,THETA,D,SSG,DSR,USC)
      REAL::VISC,GP,SSG,TMP,DSR,D,THETA,TSC,USC
      REAL::GPD
C CHANGE RECORD
C
C
C **  NONCOHEASIVE SEDIMENT SETTLING AND SHIELDS CRITERIA
C **  USING VAN RIJN'S EQUATIONS
C
      VISC=1.E-6
      GP=(SSG-1.)*9.82
      TMP=GP/(VISC*VISC)
      DSR=D*(TMP**0.333333)

      GPD=GP*D
C
C **  SHIELDS
C
      IF(DSR.LE.4.0)THEN
        THETA=0.24/DSR
      ENDIF
      IF(DSR.GT.4.0.AND.DSR.LE.10.0)THEN
        THETA=0.14/(DSR**0.64)
      ENDIF
      IF(DSR.GT.10.0.AND.DSR.LE.20.0)THEN
        THETA=0.04/(DSR**0.1)
      ENDIF
      IF(DSR.GT.20.0.AND.DSR.LE.150.0)THEN
        THETA=0.013*(DSR**0.29)
      ENDIF
      IF(DSR.GT.150.0)THEN
        THETA=0.055
      ENDIF
      TSC=GPD*THETA
      USC=SQRT(TSC)
      RETURN
      END


! mc_poly_lj_module.f90
! Routines for MC simulation, polyatomic molecule, LJ atoms
MODULE mc_module

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  USE, INTRINSIC :: iso_fortran_env, ONLY : output_unit, error_unit

  IMPLICIT NONE
  PRIVATE

  ! Public routines
  PUBLIC :: introduction, conclusion, allocate_arrays, deallocate_arrays
  PUBLIC :: potential_1, potential

  ! Public data
  INTEGER,                                PUBLIC :: n ! number of molecules
  REAL,    DIMENSION(:,:),   ALLOCATABLE, PUBLIC :: r ! centre of mass positions (3,n)
  REAL,    DIMENSION(:,:),   ALLOCATABLE, PUBLIC :: e ! quaternions (0:3,n)
  REAL,    DIMENSION(:,:,:), ALLOCATABLE, PUBLIC :: d ! bond vectors (0:3,na,n)

  ! Bond vectors in body-fixed frame (na and db are public)
  ! Isosceles triangle, 3 sites, with unit bond length and bond angle alpha, which we set to 75 degrees here
  REAL,                  PARAMETER         :: pi = 4.0*ATAN(1.0)
  REAL,                  PARAMETER         :: alpha = 75.0 * pi / 180.0, alpha2 = alpha / 2.0
  INTEGER,               PARAMETER, PUBLIC :: na = 3
  REAL, DIMENSION(3,na), PARAMETER, PUBLIC :: db = RESHAPE ( [ &
       & -SIN(alpha2), 0.0,    -COS(alpha2)/3.0, &
       &  0.0,         0.0, 2.0*COS(alpha2)/3.0, &
       &  SIN(alpha2), 0.0,    -COS(alpha2)/3.0 ], [3,na] )

  ! Cutoff distance and force-shift parameters (all private) chosen as per the reference:
  ! S Mossa, E La Nave, HE Stanley, C Donati, F Sciortino, P Tartaglia, Phys Rev E, 65, 041205 (2002)
  REAL, PARAMETER :: r_cut   = 2.612 ! in sigma=1 units, where r_cut = 1.2616 nm, sigma = 0.483 nm
  REAL, PARAMETER :: sr_cut  = 1.0/r_cut, sr_cut6 = sr_cut**6, sr_cut12 = sr_cut6**2
  REAL, PARAMETER :: lambda1 = 4.0*(7.0*sr_cut6-13.0*sr_cut12)
  REAL, PARAMETER :: lambda2 = -24.0*(sr_cut6-2.0*sr_cut12)*sr_cut

  INTEGER, PARAMETER :: lt = -1, gt = 1 ! Options for j-range

  ! Public derived type
  TYPE, PUBLIC :: potential_type   ! A composite variable for interactions comprising
     REAL    :: pot ! the potential energy
     REAL    :: vir ! the virial and
     LOGICAL :: ovr ! a flag indicating overlap (i.e. pot too high to use)
   CONTAINS
     PROCEDURE :: add_potential_type
     PROCEDURE :: subtract_potential_type
     GENERIC   :: OPERATOR(+) => add_potential_type
     GENERIC   :: OPERATOR(-) => subtract_potential_type
  END TYPE potential_type

CONTAINS

  FUNCTION add_potential_type ( a, b ) RESULT (c)
    IMPLICIT NONE
    TYPE(potential_type)              :: c    ! Result is the sum of
    CLASS(potential_type), INTENT(in) :: a, b ! the two inputs
    c%pot = a%pot  +   b%pot
    c%vir = a%vir  +   b%vir
    c%ovr = a%ovr .OR. b%ovr
  END FUNCTION add_potential_type

  FUNCTION subtract_potential_type ( a, b ) RESULT (c)
    IMPLICIT NONE
    TYPE(potential_type)              :: c    ! Result is the difference of
    CLASS(potential_type), INTENT(in) :: a, b ! the two inputs
    c%pot = a%pot  -   b%pot
    c%vir = a%vir  -   b%vir
    c%ovr = a%ovr .OR. b%ovr ! This is meaningless, but inconsequential
  END FUNCTION subtract_potential_type

  SUBROUTINE introduction
    IMPLICIT NONE

    INTEGER :: i
    REAL    :: diameter

    WRITE ( unit=output_unit, fmt='(a)' ) 'Lennard-Jones potential'
    WRITE ( unit=output_unit, fmt='(a)' ) 'Cut-and-force-shifted'
    WRITE ( unit=output_unit, fmt='(a)' ) 'Diameter, sigma = 1'
    WRITE ( unit=output_unit, fmt='(a)' ) 'Well depth, epsilon = 1'

    WRITE ( unit=output_unit, fmt='(a,t40,i15)' ) 'Number of atoms per molecule', na
    DO i = 1, na ! Loop over atoms
       WRITE ( unit=output_unit, fmt='(a,i1,t40,3f15.6)' ) 'Body-fixed atom vector ', i, db(:,i)
    END DO ! End loop over atoms

    diameter = 2.0 * SQRT ( MAXVAL ( SUM(db**2,dim=1) ) )
    WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Molecular diameter', diameter
    WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'r_cut', r_cut
    WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Force-shift lambda1', lambda1
    WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Force-shift lambda2', lambda2

  END SUBROUTINE introduction

  SUBROUTINE conclusion
    IMPLICIT NONE

    WRITE ( unit=output_unit, fmt='(a)') 'Program ends'

  END SUBROUTINE conclusion

  SUBROUTINE allocate_arrays ( box )
    IMPLICIT NONE
    REAL, INTENT(in) :: box   ! simulation box length

    REAL :: rm_cut_box, diameter

    ALLOCATE ( r(3,n), e(0:3,n), d(3,na,n) )

    diameter   = 2.0 * SQRT ( MAXVAL ( SUM(db**2,dim=1) ) )
    rm_cut_box = ( r_cut+diameter ) / box
    IF ( rm_cut_box > 0.5 ) THEN
       WRITE ( unit=error_unit, fmt='(a,f15.6)') 'rm_cut/box too large ', rm_cut_box
       STOP 'Error in allocate_arrays'
    END IF

  END SUBROUTINE allocate_arrays

  SUBROUTINE deallocate_arrays
    IMPLICIT NONE

    DEALLOCATE ( r, e, d )

  END SUBROUTINE deallocate_arrays

  FUNCTION potential ( box ) RESULT ( total )
    IMPLICIT NONE
    TYPE(potential_type) :: total ! Returns a composite of pot, vir etc
    REAL, INTENT(in)     :: box   ! Simulation box length

    ! total%pot is the nonbonded cut-and-shifted potential energy for whole system
    ! total%vir is the corresponding virial for whole system
    ! total%ovr is a flag indicating overlap (potential too high) to avoid overflow
    ! If this flag is .true., the values of total%pot etc should not be used
    ! Actual calculation is performed by function potential_1

    TYPE(potential_type) :: partial ! Molecular contribution to total
    INTEGER              :: i

    IF ( ANY ( SHAPE(r)  /= [3,n] ) ) THEN ! should never happen
       WRITE ( unit=error_unit, fmt='(a,3i15)' ) 'Array bounds error for r', n, SHAPE(r)
       STOP 'Error in potential'
    END IF

    IF ( ANY ( SHAPE(d)  /= [3,na,n] ) ) THEN ! should never happen
       WRITE ( unit=error_unit, fmt='(a,5i15)' ) 'Array bounds error for d', na, n, SHAPE(d)
       STOP 'Error in potential'
    END IF

    total = potential_type ( pot=0.0, vir=0.0, ovr=.FALSE. ) ! Initialize

    DO i = 1, n - 1

       partial = potential_1 ( r(:,i), d(:,:,i), i, box, gt )

       IF ( partial%ovr ) THEN
          total%ovr = .TRUE. ! Overlap detected
          RETURN             ! Return immediately
       END IF

       total = total + partial

    END DO

    total%ovr = .FALSE. ! No overlaps detected (redundant, but for clarity)

  END FUNCTION potential

  FUNCTION potential_1 ( ri, di, i, box, j_range ) RESULT ( partial )
    IMPLICIT NONE
    TYPE(potential_type)                 :: partial ! Returns a composite of pot, vir etc for given molecule
    REAL,    DIMENSION(3),    INTENT(in) :: ri      ! Coordinates of molecule of interest
    REAL,    DIMENSION(3,na), INTENT(in) :: di      ! Bond vectors of molecule of interest
    INTEGER,                  INTENT(in) :: i       ! Index of molecule of interest
    REAL,                     INTENT(in) :: box     ! Simulation box length
    INTEGER, OPTIONAL,        INTENT(in) :: j_range ! Optional partner index range

    ! partial%pot is the nonbonded cut-and-shifted potential energy of molecule ri,ei with a set of other molecules
    ! partial%vir is the corresponding virial of molecule ri,ei
    ! partial%ovr is a flag indicating overlap (potential too high) to avoid overflow
    ! If this is .true., the values of partial%pot etc should not be used
    ! The coordinates in ri and ei are not necessarily identical with those in r(:,i) and e(:,i)
    ! The optional argument j_range restricts partner indices to j>i, or j<i

    ! It is assumed that r has been divided by box
    ! Results are in LJ units where sigma = 1, epsilon = 1
    ! Note that this is the force-shifted LJ potential with a linear smoothing term
    ! S Mossa, E La Nave, HE Stanley, C Donati, F Sciortino, P Tartaglia, Phys Rev E, 65, 041205 (2002)

    INTEGER               :: j, j1, j2, a, b
    REAL                  :: diameter, rm_cut_box, rm_cut_box_sq, r_cut_sq
    REAL                  :: sr2, sr6, sr12, rij_sq, rab_sq, virab, rmag
    REAL, DIMENSION(3)    :: rij, rab, fab
    REAL, PARAMETER       :: sr2_ovr = 1.77 ! overlap threshold (pot > 100)
    TYPE(potential_type)  :: pair

    IF ( PRESENT ( j_range ) ) THEN
       SELECT CASE ( j_range )
       CASE ( lt ) ! j < i
          j1 = 1
          j2 = i-1
       CASE ( gt ) ! j > i
          j1 = i+1
          j2 = n
       CASE default ! should never happen
          WRITE ( unit = error_unit, fmt='(a,i10)') 'j_range error ', j_range
          STOP 'Impossible error in potential_1'
       END SELECT
    ELSE
       j1 = 1
       j2 = n
    END IF

    diameter      = 2.0 * SQRT ( MAXVAL ( SUM(db**2,dim=1) ) )
    rm_cut_box    = ( r_cut + diameter ) / box ! Molecular cutoff in box=1 units
    rm_cut_box_sq = rm_cut_box**2              ! squared
    r_cut_sq      = r_cut**2                   ! Potential cutoff squared in sigma=1 units

    partial = potential_type ( pot=0.0, vir=0.0, ovr=.FALSE. ) ! Initialize

    DO j = j1, j2 ! Loop over selected range of partner molecules

       IF ( i == j ) CYCLE ! Skip self

       rij(:) = ri(:) - r(:,j)            ! Centre-centre separation vector
       rij(:) = rij(:) - ANINT ( rij(:) ) ! Periodic boundaries in box=1 units
       rij_sq = SUM ( rij**2 )            ! Squared centre-centre separation in box=1 units

       IF ( rij_sq < rm_cut_box_sq ) THEN ! Test within molecular cutoff

          rij = rij * box ! Now in sigma = 1 units

          ! Double loop over atoms on both molecules
          DO a = 1, na
             DO b = 1, na

                rab    = rij + di(:,a) - d(:,b,j) ! Atom-atom vector, sigma=1 units
                rab_sq = SUM ( rab**2 )           ! Squared atom-atom separation, sigma=1 units

                IF ( rab_sq < r_cut_sq ) THEN ! Test within potential cutoff

                   sr2      = 1.0 / rab_sq  ! (sigma/rab)**2
                   pair%ovr = sr2 > sr2_ovr ! Overlap if too close

                   IF ( pair%ovr ) THEN
                      partial%ovr = .TRUE. ! Overlap detected
                      RETURN               ! Return immediately
                   END IF

                   rmag     = SQRT(rab_sq)
                   sr6      = sr2**3
                   sr12     = sr6**2
                   pair%pot = 4.0*(sr12-sr6) + lambda1 + lambda2*rmag ! LJ atom-atom pair potential (force-shifted)
                   virab    = 24.0*(2.0*sr12-sr6 ) - lambda2*rmag     ! LJ atom-atom pair virial
                   fab      = rab * virab * sr2                       ! LJ atom-atom pair force
                   pair%vir = DOT_PRODUCT ( rij, fab )                ! Contribution to molecular virial

                   partial = partial + pair

                END IF ! End test within potential cutoff

             END DO
          END DO
          ! End double loop over atoms on both molecules

       END IF ! End test within molecular cutoff

    END DO ! End loop over selected range of partner molecules

    ! Include numerical factors
    partial%vir = partial%vir / 3.0 ! Divide virial by 3
    partial%ovr = .FALSE.           ! No overlaps detected (redundant, but for clarity)

  END FUNCTION potential_1

END MODULE mc_module


text:
      INTEGER FUNCTION IDT_IBJQUA(k,Idbamj)

C***********************************************************************
C                                                                      *
C     quark contents according to BAMJET conventions                   *
C     (random selection in case of quark mixing)                       *
C                                                                      *
C     input:   IDBAMJ BAMJET particle code                             *
C              K      1..3   quark number                              *
C                                                                      *
C     output:  1   u      7   u bar                                    *
C              2   d      8   d bar                                    *
C              3   s      9   s bar                                    *
C              4   c     10   c bar                                    *
C                                                                      *
C This version written by R. Engel.                                    *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION DT_RNDM , one
      INTEGER i , id , Idbamj , idold , it , itab , k
      SAVE

      DIMENSION itab(3,210)
Csr 10.1.94
C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
C
Csr 10.1.94
C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
Csr 10.1.94
C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
C
      DATA ((itab(i,k),i=1,3),k=1,30)/1 , 1 , 2 , 7 , 7 , 8 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 2 ,
     &      2 , 7 , 8 , 8 , 0 , 0 , 0 , 0 , 0 , 0 , 3 , 8 , 0 , 1 , 8 ,
     &      0 , 2 , 7 , 0 , 1 , 9 , 0 , 3 , 7 , 0 , 3 , 1 , 2 , 9 , 7 ,
     &      8 , 2 , 9 , 0 , 2 , 2 , 3 , 1 , 1 , 3 , 1 , 2 , 3 , 201 ,
     &      202 , 0 , 2 , 9 , 0 , 3 , 8 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0/
      DATA ((itab(i,k),i=1,3),k=31,60)/3 , 9 , 0 , 1 , 8 , 0 , 203 ,
     &      204 , 0 , 2 , 7 , 0 , 0 , 0 , 0 , 1 , 9 , 0 , 2 , 9 , 0 ,
     &      3 , 7 , 0 , 3 , 8 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      1 , 1 , 1 , 1 , 1 , 2 , 1 , 2 , 2 , 2 , 2 , 2 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0/
      DATA ((itab(i,k),i=1,3),k=61,90)/0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 7 , 7 , 7 , 7 , 7 ,
     &      8 , 7 , 8 , 8 , 8 , 8 , 8 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0/
      DATA ((itab(i,k),i=1,3),k=91,120)/0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 , 9 , 0 , 1 , 3 , 3 , 2 , 3 ,
     &      3 , 7 , 7 , 9 , 7 , 8 , 9 , 8 , 8 , 9 , 7 , 9 , 9 , 8 , 9 ,
     &      9 , 1 , 1 , 3 , 1 , 2 , 3 , 2 , 2 , 3 , 1 , 3 , 3 , 2 , 3 ,
     &      3 , 3 , 3 , 3 , 7 , 7 , 9 , 7 , 8 , 9 , 8 , 8 , 9 , 7 , 9 ,
     &      9 , 8 , 9 , 9 , 9 , 9 , 9 , 4 , 7 , 0 , 4 , 8 , 0 , 2 , 10 ,
     &      0 , 1 , 10 , 0 , 4 , 9 , 0/
      DATA ((itab(i,k),i=1,3),k=121,150)/3 , 10 , 0 , 4 , 10 , 0 , 4 ,
     &      7 , 0 , 4 , 8 , 0 , 2 , 10 , 0 , 1 , 10 , 0 , 4 , 9 , 0 ,
     &      3 , 10 , 0 , 4 , 10 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 2 ,
     &      4 , 1 , 3 , 4 , 2 , 3 , 4 , 1 , 1 , 4 , 0 , 0 , 0 , 2 , 2 ,
     &      4 , 0 , 0 , 0 , 0 , 0 , 0 , 3 , 3 , 4 , 1 , 4 , 4 , 2 , 4 ,
     &      4 , 3 , 4 , 4 , 7 , 8 , 10 , 7 , 9 , 10/
      DATA ((itab(i,k),i=1,3),k=151,180)/8 , 9 , 10 , 7 , 7 , 10 , 0 ,
     &      0 , 0 , 8 , 8 , 10 , 0 , 0 , 0 , 0 , 0 , 0 , 9 , 9 , 10 ,
     &      7 , 10 , 10 , 8 , 10 , 10 , 9 , 10 , 10 , 1 , 1 , 4 , 1 ,
     &      2 , 4 , 2 , 2 , 4 , 1 , 3 , 4 , 2 , 3 , 4 , 3 , 3 , 4 , 1 ,
     &      4 , 4 , 2 , 4 , 4 , 3 , 4 , 4 , 4 , 4 , 4 , 7 , 7 , 10 , 7 ,
     &      8 , 10 , 8 , 8 , 10 , 7 , 9 , 10 , 8 , 9 , 10 , 9 , 9 , 10 ,
     &      7 , 10 , 10 , 8 , 10 , 10 , 9 , 10 , 10 , 10 , 10 , 10/
      DATA ((itab(i,k),i=1,3),k=181,210)/0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 7 , 0 , 2 , 8 , 0 , 1 , 7 ,
     &      0 , 2 , 8 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
     &      0 , 0 , 0 , 0 , 0 , 0 , 0/
      DATA idold/0/

      one = 1.0D0
      IF ( itab(1,Idbamj).LE.200 ) THEN
         id = itab(k,Idbamj)
      ELSE
         IF ( idold.NE.Idbamj ) THEN
            it = INT((itab(2,Idbamj)-itab(1,Idbamj)+0.999999D0)
     &           *DT_RNDM(one)+itab(1,Idbamj))
         ELSE
            idold = 0
         END IF
         id = itab(k,it)
      END IF
      idold = Idbamj
      IDT_IBJQUA = id

      END FUNCTION

max_stars_repo_name: pzhristov/DPMJET

max_issues_repo_name: pzhristov/DPMJET

max_forks_repo_name: pzhristov/DPMJET


text:
ccc_____________________________________________________________________
ccc
      subroutine rdblk_SEED(npts,nch,ix,ierr)

ccc   returns "some" data points for nch channels of data,
ccc   each in a separate mini-seed file.   reads additional
ccc   blocks as needed, allows for gaps, adds sample numbers
ccc   to output multiplexed integer data array ix  ...

ccc  (tried to make interface/arguments similar to old versioni, but ...)
ccc   On entry it is assumed that the array ix contains npts+nix(nch)
ccc   data points, where nix varies with channel; all have at least
ccc   npts samples, which were used by the calling program on the
ccc   previous call.  Also in common block DATABLK_SEED the contents
ccc   of the next data block read from each file are stored in array
ccc   next_blk (along with info about numbers of pts read, gaps, etc.)
ccc   THe routine moves the unused portion of ix (i.e., the nix(.)
ccc   points for each channel after the first npts) to the top of
ccc   the array, and depending on various conditions (gap size if any,
ccc   how big nix(ich) is already, etc.) adds new points to the bottom
ccc   of the array (all of next_blk(ich)+ any missing values to fill
ccc   in small enough gaps).  If appropriate a new
ccc   block is read in (sometimes no points are moved from next_blk;
ccc   then no new block is read).  When ix has emptied for a channel
ccc   for which an EOF has been found, the routine returns ierr = -1
ccc   If a large gap (gt ngap_max) is found, and ix for
ccc   the channel with the gap has been emptied, the routine returns
ccc    ierr = - 3   ... in this case the calling program should next
ccc   align the blocks (already in next_blk ... but some searching
ccc   through additional data will be required usually ... see
ccc   align_seed.f .)   Then this routine can be called again, and
ccc   reading can continue.

      include 'seed.inc'
      record /INT_TIME/exptime
      integer ix(0:nch,*),nch,npts,npts1,ich,i,ierr,read_ms,
     &   irec_1(2)
      double precision tdiff
      logical enuf_already(nchmx),big_gap(nchmx),lend

c      write(0,*) 'ngot',ngot
c      write(0,*) 'nix',nix
c      write(0,*) 'ngap',ngap

      ierr = 0
      npts1 = nix(1) + ngot(1) + ngap(1)
      do ich = 1,nch
         big_gap(ich) = (ngap(ich).gt.ngap_max)
         enuf_already(ich) = nix(ich).gt.nix_enuf
ccc      move "left over" points from previous read to top of buffer
         do i=npts+1,npts+nix(ich)
            ix(ich,i-npts) = ix(ich,i)
         end do
         if(enuf_already(ich) .or. big_gap(ich)) then
ccc         don't add points to ix for this channel
            npts1 = min(npts1,nix(ich))
         else
ccc        first fill in missing value codes in gap (if needed)
            do i = 1,ngap(ich)
               ix(ich,nix(ich)+i) = msval
            enddo
ccc         then move data from next block into output array,
            do i=1,ngot(ich)
               ix(ich,nix(ich)+ngap(ich)+i) = next_blk(i,ich)
            end do
ccc         calculate number of points available for all channels
ccc         this is number of points returned (npts)
            npts1 = min(npts1,nix(ich)+ngap(ich)+ngot(ich))
         endif
      end do
      npts = npts1
c      write(0,*) 'npts',npts
ccc   recompute # of left over points
      do ich = 1,nch
         if(enuf_already(ich) .or. big_gap(ich))  then
            nix(ich) = nix(ich) - npts
         else
            nix(ich) = nix(ich) + ngot(ich) + ngap(ich) - npts
         endif
      end do
ccc   add record numbers to the first npts points
      do i = 1,npts
         irec = irec + 1
         ix(0,i) = irec
      end do
c      write(0,*) 'New nix',nix

ccc   read in next block
      do ich = 1,nch
         if( (iend(ich).ge.0) .and. (.not.enuf_already(ich))
     &     .and. (.not.big_gap(ich)) ) then
ccc         continue reading file for channel ich
ccc         first save last header block
            call time_interval(ngot(ich),hdr(ich).sample_rate,second,
     &         ticks)
            call add_time(hdr(ich).begtime,second,ticks,exptime)
            ngot(ich) = read_ms(hdr(ich),next_blk(1,ich),nblkmx,
     &      inunits(ich))
c            call wrt_time(exptime)
c            call wrt_time(hdr(ich).begtime)
            if(ngot(ich) .le. 0 ) then
c               write(0,*) 'EOF: ngot(ich),ich',ngot(ich),ich
               iend(ich) = -1
               ngot(ich) = 0
            else
ccc            compute gap between blocks (if any) for channel ich
               ngap(ich) = nint(tdiff(hdr(ich).begtime,exptime)/
     &                     (TICKS_PER_SEC*ddr))
c               write(0,*) 'Reading for channel #',ich,' got ',ngot(ich),
c     &             'gap = ',ngap(ich)
                if(ngap(ich) .gt. 0 ) then
c                   write(0,*) 'NGAP ',(ngap(k),k=1,nch)
                   call rec_num(hdr(ich).begtime,doy0,samp_rate,irec_1)
                   dt_chng_rec(ich,dt_chng_n(ich)) = irec_1(1)
                   dt_chng_n(ich) = dt_chng_n(ich) + 1
                   dt(ich,dt_chng_n(ich)) = float(irec_1(2))/
     &                   TICKS_PER_SEC
                   dt_chng_rec(ich,dt_chng_n(ich)) = maxint
                endif
            endif
         endif
      end do
ccc   set ierr ...
      if(npts .gt. 0 ) then
ccc      all OK ... keep going
         ierr = 0
      else
ccc      end of data stream???
         lend = .false.
         do ich = 1,nch
            lend = lend .or.iend(ich) .lt. 0
         enddo
         if(lend) then
            ierr = -1
         else
ccc         must be large data gap ...
            write(0,*) 'Large gap?'
c            write(0,*) 'IEND',(iend(k),k=1,nch)
            ierr = -3
         endif
ccc      (ierr = -2  can't occur for seed files ...)
      endif
      return
      end

max_stars_repo_name: simpeg-research/iris-mt-scratch

max_issues_repo_name: simpeg-research/iris-mt-scratch

max_forks_repo_name: simpeg-research/iris-mt-scratch


text:
c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine rarray(ithistraj,time,xx,nat)

      implicit none
      include 'param.f'

      integer i,j,k,nat,l,ithistraj
      double precision rr(mnat*(mnat-1)/2),rij,xx(3,mnat),time,
     & symbol(mnat)

      l=0
      do 10 i=1,nat
      do 10 j=i+1,nat
      rij=0.d0
      do k=1,3
      rij = rij + (xx(k,i)-xx(k,j))**2
      enddo
      rij = dsqrt(rij)
      l=l+1
      rr(l)=rij
 10   continue

      write(43,143)ithistraj,time*autofs,(rr(k)*autoang,k=1,l)
 143  format(i10,f20.8,100(f20.8))

      return
      end

max_stars_repo_name: kevinmooreiii/DiNT

max_issues_repo_name: kevinmooreiii/DiNT

max_forks_repo_name: kevinmooreiii/DiNT


text:
module parallel_mod

use constants_mod
use mpi_f08

character(MPI_MAX_PROCESSOR_NAME) hostname

# if defined(__GFORTRAN__)
interface
    function MPI_Comm_f2c(fcomm) result(ccomm) bind(c,name="MPI_Comm_f2c")
        use iso_c_binding, only: c_ptr, c_int

        integer(c_int), intent(in), value   :: fcomm
        type(c_ptr)                         :: ccomm

    end function
end interface
# endif

interface
    !! int sched_getcpu(void);
    function sched_getcpu() result(cpuid) bind(c,name="sched_getcpu")
        use iso_c_binding, only: c_int
        integer(c_int) :: cpuid
    end function
end interface

type(MPI_COMM), save :: COMM

integer :: nranks,ierr

contains

subroutine hook_init_100

    use share_mod, only: rt => runtime

    integer :: ierr,provided

# ifdef _OPENMP
    call MPI_Init_thread(MPI_THREAD_FUNNELED, provided, ierr)
# else
    call MPI_Init_thread(MPI_THREAD_SINGLE, provided, ierr)
# endif

    rt%mpi%comm = MPI_COMM_WORLD

    call MPI_COMM_RANK(rt%mpi%comm, rt%mpi%rank, ierr)
    call MPI_COMM_SIZE(rt%mpi%comm, rt%mpi%size, ierr)

    rt%mpi%root = rt%mpi%rank == 0
    rt%mpi%info = MPI_INFO_NULL
    rt%mpi%ccomm = MPI_Comm_f2c(rt%mpi%comm%mpi_val)

    rt%ncpus = rt%mpi%size

    COMM = rt%mpi%comm
    nranks = rt%mpi%size

end subroutine

subroutine hook_nuke_900

    call MPI_FINALIZE(ierr)

end subroutine

subroutine parallel_ping(dest,tag)

    integer, intent(in)             :: dest
    integer, intent(in), optional   :: tag
    integer                         :: ierr

    if (present(tag)) then
        call MPI_SEND(0, 1, MPI_INTEGER, dest, tag, COMM, ierr)
    else
        call MPI_SEND(0, 1, MPI_INTEGER, dest, 0, COMM, ierr)
    endif

end subroutine

subroutine parallel_pong(src,tag)

    integer, intent(in)             :: src
    integer, intent(in), optional   :: tag

    integer                         :: ierr
    type(MPI_STATUS)                :: stat

    if (present(tag)) then
        call MPI_Probe(src, tag, COMM, stat, ierr)
    else
        call MPI_Probe(src, 0, COMM, stat, ierr)
    end if

end subroutine

subroutine barrier(ierr)

    integer, intent(out), optional :: ierr

    integer :: ierr2

    if (nranks < 2) return

    if (present(ierr)) then
         call MPI_BARRIER(comm, ierr)
    else
         call MPI_BARRIER(comm, ierr2)
    end if

end subroutine

end module

max_stars_repo_name: jmark/nemo

max_issues_repo_name: jmark/nemo

max_forks_repo_name: jmark/nemo


text:
MODULE m_symMMPmat

   USE m_rotMMPmat
   USE m_types
   USE m_constants

   IMPLICIT NONE

   PRIVATE
   PUBLIC symMMPmat

   INTERFACE symMMPmat
      PROCEDURE :: symMMPmatFull, symMMPmatoneSpin
   END INTERFACE

   CONTAINS

   PURE FUNCTION symMMPmatFull(mmpmat,sym,natom,l,phase) Result(mmpmatSym)

      COMPLEX,          INTENT(IN)  :: mmpmat(-lmaxU_const:,-lmaxU_const:,:)
      TYPE(t_sym),      INTENT(IN)  :: sym
      INTEGER,          INTENT(IN)  :: natom
      INTEGER,          INTENT(IN)  :: l
      LOGICAL,OPTIONAL, INTENT(IN)  :: phase !multiply spin-offdiagonal phase
                                             !(if the full matrix is not given)

      COMPLEX :: mmpmatSym(-lmaxU_const:lmaxU_const,-lmaxU_const:lmaxU_const,SIZE(mmpmat,3))
      REAL    :: symFac
      INTEGER :: it,is,isi
      COMPLEX :: offdPhase

      mmpmatSym = cmplx_0

      symFac = 1.0/sym%invarind(natom)

      DO it = 1, sym%invarind(natom)
         is  = sym%invarop(natom,it)
         isi = sym%invtab(is)

         offdPhase = cmplx_1
         IF(PRESENT(phase)) THEN
            IF(phase) offdPhase = exp(ImagUnit*sym%phase(isi))
         ENDIF

         mmpmatSym = mmpmatSym + symFac * offdPhase * rotMMPmat(mmpmat,dwgn=sym%d_wgn(:,:,l,isi))

      ENDDO

   END FUNCTION symMMPmatFull

   PURE FUNCTION symMMPmatoneSpin(mmpmat,sym,natom,l,phase) Result(mmpmatSym)

      COMPLEX,          INTENT(IN)  :: mmpmat(-lmaxU_const:,-lmaxU_const:)
      TYPE(t_sym),      INTENT(IN)  :: sym
      INTEGER,          INTENT(IN)  :: natom
      INTEGER,          INTENT(IN)  :: l
      LOGICAL,OPTIONAL, INTENT(IN)  :: phase

      INTEGER :: ilow(2),iup(2)
      COMPLEX :: mmpmatSym(-lmaxU_const:lmaxU_const,-lmaxU_const:lmaxU_const)
      COMPLEX, ALLOCATABLE :: mmpmatOut2(:,:,:),mmpmatIn(:,:,:)

      !Add "extra spin dimension"
      ilow = LBOUND(mmpmat)
      iup  = UBOUND(mmpmat)
      ALLOCATE(mmpmatIn(ilow(1):iup(1),ilow(2):iup(2),1),source=cmplx_0)
      mmpmatIn(:,:,1) = mmpmat

      ALLOCATE(mmpmatOut2,mold=mmpMatIn)
      mmpmatOut2 = symMMPmatFull(mmpmatIn,sym,natom,l,phase=phase)

      mmpmatSym = mmpmatOut2(:,:,1)

   END FUNCTION symMMPmatoneSpin

END MODULE m_symMMPmat

max_stars_repo_name: MRedies/FLEUR

max_issues_repo_name: MRedies/FLEUR

max_forks_repo_name: MRedies/FLEUR


text:
    subroutine admit1(P, Zdc, C, K, YS1, Y, RG, RT)

    implicit none
    !include 'Constants.fi'

!  Sub-Program Arguments
      real P         ! (Input) period length (s)
      real Zdc       ! (Input) layer depth (decimetre)
      real C         ! (Input)
      real K         ! (Input)
      COMPLEX YS1    ! (Input)
      COMPLEX Y      !(Output)
      COMPLEX RG     !(Output)
      COMPLEX RT     !(Output)

!  Local Variables
      real W
      real D
      COMPLEX YINF
      COMPLEX R
      COMPLEX SINH
      COMPLEX COSH
      COMPLEX TANH

      real :: pi = 3.14159265

! Implementation Section ----------------------------------

      W = 2.*PI / P
      D = SQRT(2.*K / (W*C))
      YINF = (1.,1.)*SQRT(W*C*K / 2.)
      R = (1.,1.)*Zdc / D
      SINH = (CEXP(R) - CEXP( - R)) / 2.
      COSH = (CEXP(R) + CEXP( - R)) / 2.
      TANH = SINH / COSH

      RG = SINH*YINF / YS1 + COSH
      RT = SINH*YS1 / YINF + COSH
      Y = YINF*(TANH + YS1 / YINF) / (TANH*YS1 / YINF + 1.)

      return

    end subroutine admit1

max_stars_repo_name: vstocca/dssat-csm-os

max_issues_repo_name: vstocca/dssat-csm-os

max_forks_repo_name: vstocca/dssat-csm-os


program fworld
!@(#) perspective, objects, color, software text
!
! most of the things in this program have been done before but it has
! a certain novelty value.
!
!(LICENSE:PD)

   use M_draw

   integer BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE
   parameter(BLACK = 0)
   parameter(RED = 1)
   parameter(GREEN = 2)
   parameter(YELLOW = 3)
   parameter(BLUE = 4)
   parameter(MAGENTA = 5)
   parameter(CYAN = 6)
   parameter(WHITE = 7)

   integer SPHERE
   real RADIUS, PI
   parameter (RADIUS = 10.0, PI = 3.1415926535, SPHERE = 1)

   character(len=20) :: dev

   print*,'Enter device:'
   read(*,'(a)') dev
   call vinit(dev)

   call vsetflush(.false.)

   call clipping(.false.)

   call font('futura.m')

   call perspective(80.0, 1.0, 0.001, 50.0)
   call lookat(13.0, 13.0, 8.0, 0.0, 0.0, 0.0, 0.0)

   call color(BLACK)
   call clear

   call makesphere

!
!       draw the main one in cyan
!
   call color(CYAN)

   call callobj(SPHERE)

!
!       draw a smaller one outside the main one in white
!
   call color(WHITE)

   call pushmatrix
   call translate(0.0, (-1.4) * RADIUS, 1.4 * RADIUS)
   call scale(0.3, 0.3, 0.3)
   call callobj(SPHERE)
   call popmatrix

!
!       scale the text
!
   call boxfit(2.0 * PI * RADIUS, 0.25 * RADIUS, 31)

!
!       now write the text in rings around the main sphere
!

   call color(GREEN)
   call showroundtext('Around the world in eighty days ')

   call color(BLUE)
!
!       note: that software text is rotated here as
!       anything else would be whether you use textang
!       or rotate depends on what you are trying to do.
!       Experience is the best teacher here.
!
   call rotate(90.0, 'x')
   call showroundtext('Around the world in eighty days ')

   call color(RED)
   call rotate(90.0, 'z')
   call showroundtext('Around the world in eighty days ')

   call vflush()
   idum=getkey()

   call vexit

end program fworld
!
! showroundtext
!
!       draw string str wrapped around a circle in 3d
!
subroutine showroundtext(str)

   use M_draw

   character(len=*) :: str

   real i, inc, RADIUS
   parameter (RADIUS = 10.0)
   integer j

   inc = 360.0 / float(len_trim(str))

   j = 1
   i=0
   do i10 = 1, len_trim(str)
      call pushmatrix
!
!                       find the spot on the edge of the sphere
!                       by making it (0, 0, 0) in world coordinates
!
      call rotate(i, 'y')
      call translate(0.0, 0.0, RADIUS)

      call move(0.0, 0.0, 0.0)

      call drawchar(str(j:j))
      j = j + 1
      call popmatrix
      i=i+inc
   enddo

end subroutine showroundtext

!
! makesphere
!
!       create the sphere object
!
subroutine makesphere

   use M_draw

   integer SPHERE
   parameter (SPHERE = 1)
   parameter(PI = 3.1415926535)
   parameter(RADIUS = 10.0)
   real i

   call makeobj(SPHERE)

   do i10 = 0, 180, 20
      call pushmatrix
      i=real(i10)
      call rotate(i, 'y')
      call circle(0.0, 0.0, RADIUS)
      call popmatrix
   enddo

   call pushmatrix
   call rotate(90.0, 'x')
   do i20 = -90, 90, 20
      a=real(i20)
      r = RADIUS * cos(a*PI/180.0)
      z = RADIUS * sin(a*PI/180.0)
      call pushmatrix
      call translate(0.0, 0.0, -z)
      call circle(0.0, 0.0, r)
      call popmatrix
   enddo
   call popmatrix

   call closeobj

end subroutine makesphere


text:
/*****************************************************************************
 * wb_dma_test_base.f
 *****************************************************************************/

+UVM_TESTNAME=wb_dma_register_reset_test


text:
module utils

use, intrinsic :: iso_c_binding, only : c_int
implicit none (type, external)

contains

pure subroutine error_fortran(value) bind(C)

  integer(c_int), intent(in) :: value

  error stop value

end subroutine error_fortran

end module utils

max_stars_repo_name: scivision/fortran-c-cpp-interface

max_issues_repo_name: scivision/fortran-c-cpp-interface

max_forks_repo_name: scivision/fortran-c-cpp-interface


text:
	SUBROUTINE GH_BKTB ( iret )
C************************************************************************
C* GH_BKTB								*
C*									*
C* This subroutine reads the breakpoint table.				*
C*									*
C* GH_BKTB ( IRET )                                                     *
C*									*
C* Output Parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return             *
C*					 -9 = error in opening table    *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 4/03	                                        *
C* D. Kidwell/NCEP	11/03	Stid ->bkstid (in ghcmn), new bktbch fmt*
C* D. Kidwell/NCEP	 1/04	Changed storage for special fill areas  *
C* m.gamazaychikov/SAIC	03/04	from GH_BKRD				*
C* m.gamazaychikov/SAIC	07/04	removed obsolete lines of code		*
C* m.gamazaychikov/SAIC	01/05	added a check after call to ST_NUMB	*
C* M. Li/SAIC            1/06   Changed county codes to zone            *
C* S. Gilbert/NCEP	10/07	Added bkstate and bkcntry to common	*
C* S. Gilbert/NCEP	06/09	Added last ME sequence number to common	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ghcmn.cmn'
C*
	CHARACTER     	table*20, type*4, stnnam (MAXBK)*32
        CHARACTER       tag*25, dirsym*160, tblnam*72, value*12
	INTEGER		isnm (MAXBK), iarea (MAXBK), itype (MAXBK)
	REAL		selv (MAXBK)
C------------------------------------------------------------------------
	iret  = 0
	value = ' '
C
C*      Read the value of tag TCV_ZONE in prefs.tbl.
C
        tag     = 'TCV_ZONE'
        tblnam  = 'prefs.tbl'
        dirsym  = 'config'
C
        CALL ST_NULL ( tblnam, tblnam, lens, ier )
        CALL ST_NULL ( dirsym, dirsym, lens, ier )
        CALL ST_NULL ( tag, tag, lens, ier)
        CALL CTB_RDPRF ( tblnam, dirsym, tag, value, ier1 )
        CALL ST_RNUL ( value, value, lens, ier )
C
C*	Open the table.
C
	IF ( value .eq. 'COUNTY' ) THEN
	    table = 'tcabkpt.tbl'
	  ELSE
	    table = 'tcabkptlz.tbl'
	END IF
	type  = 'stns'
        CALL FL_TBOP ( table, type, lun, ier )
C
        IF ( ier .ne. 0 ) THEN
	    iret = -9
            RETURN
        END IF
C
C*	Read the breakpoint table.
C
	maxstn = MAXBK
	CALL TB_ASTN ( lun, maxstn, nstn, bkstid, stnnam, isnm, bkstate,
     +		       bkcntry, bklat, bklon, selv, ibkpri, bktbch, ier )
C
C*	Get count of breakpoints.
C
	DO ii = 1, NAREAS
	    nbkpts ( ii ) = 0
	END DO
C
	DO ii = 1, nstn
	    iarea ( ii ) = ibkpri ( ii ) / 10
	    itype ( ii ) = MOD ( ibkpri ( ii ), 10 )
	    IF ( ( ( itype ( ii ) .eq. 0 ) .or.
     +             ( itype ( ii ) .eq. 9 ) ) .and.
     +		 ( iarea ( ii ) .ge. 1 ) .and.
     +		 ( iarea ( ii ) .le. NAREAS ) ) THEN
		nbkpts ( iarea ( ii ) ) = nbkpts ( iarea ( ii ) ) + 1
	    END IF
	END DO
C
	larea = 0
	lines = 0
	DO ii = 1, nstn
     	    ibkseq ( ii ) = 0
	    IF ( iarea ( ii ) .ne. larea ) THEN
		iseq  = 0
		larea = iarea ( ii )
		indxbk ( larea ) = ii
	    END IF
	    IF ( ( itype ( ii ) .eq. 0 ) .or.
     +           ( itype ( ii ) .eq. 9 ) ) THEN
		IF ( ( iarea ( ii ) .ge. 1 ) .and.
     +		     ( iarea ( ii ) .le. NAREAS ) ) THEN
		    iseq = iseq + 1
		    ibkseq ( ii ) = iseq
		END IF
	    END IF
	END DO
	indxbk ( NAREAS + 1 ) = nstn + 1
C
C*	Get any integer plotting range check values from the table
C
	DO jj = 1, 9
	    DO ii = 1, 2
		isnd ( ii, jj ) = 0
	    END DO
	END DO
	nsnds = 0
C
	DO ii = 1, nstn
	    IF ( iarea ( ii ) .eq. IUSGEC ) THEN
      		IF ( bktbch ( ii ) (:2 ) .ne. ' ' ) THEN
		    CALL ST_NUMB ( bktbch ( ii ) ( :2 ), isndx, ier )
                    IF ( ier. eq. 0 ) THEN
		        n1 = isndx / 10
		        n2 = MOD ( isndx, 10 )
		        IF ( ibkseq ( ii ) .gt. 0 ) THEN
		            IF ( ( n1 .ge. 1 ) .and.
     +			         ( n1 .le. 9 ) .and.
     +			         ( ( n2 .eq. 1 ) .or. ( n2 .eq. 2 ) ) )
     +			           isnd ( n2, n1 ) = ibkseq ( ii )
                            IF ( nsnds .lt. n1 ) nsnds = n1
		        END IF
		    END IF
		END IF
                IF ( bkstate(ii) .eq. 'ME' ) iseqme = ibkseq(ii)
	    END IF
C
C*          Save sequence number for last california breakpoint in
C*          section IPACIF
C
	    IF ( iarea ( ii ) .eq. IPACIF ) THEN
                IF ( bkstate(ii) .eq. 'CA' ) iseqca = ibkseq(ii)
	    END IF
	END DO
C
        CALL FL_CLOS ( lun, ier )
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak