text:
C$Procedure DSKD02 ( DSK, fetch d.p. type 2 data )

      SUBROUTINE DSKD02 ( HANDLE, DLADSC, ITEM, START, ROOM, N, VALUES )

C$ Abstract
C
C     Fetch double precision data from a type 2 DSK segment.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     DAS
C     DSK
C
C$ Keywords
C
C     DAS
C     DSK
C     FILES
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'dla.inc'
      INCLUDE 'dskdsc.inc'
      INCLUDE 'dsk02.inc'

      INTEGER               HANDLE
      INTEGER               DLADSC ( * )
      INTEGER               ITEM
      INTEGER               START
      INTEGER               ROOM
      INTEGER               N
      DOUBLE PRECISION      VALUES ( * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   DSK file handle.
C     DLADSC     I   DLA descriptor.
C     ITEM       I   Keyword identifying item to fetch.
C     START      I   Start index.
C     ROOM       I   Amount of room in output array.
C     N          O   Number of values returned.
C     VALUES     O   Array containing requested item.
C
C$ Detailed_Input
C
C     HANDLE         is the handle of a DSK file containing a type 2
C                    segment from which data are to be fetched.
C
C     DLADSC         is the DLA descriptor associated with the segment
C                    from which data are to be fetched.
C
C     ITEM           is an integer "keyword" parameter designating the
C                    item to fetch. In the descriptions below, note
C                    that "model" refers to the model represented by
C                    the designated segment.  This model may be a
C                    subset of a larger model.
C
C                    Names and meanings of parameters supported by this
C                    routine are:
C
C                       KWDSC      DSK descriptor of segment.  See the
C                                  INCLUDE file dskdsc.inc for a
C                                  discussion of the contents of DSK
C                                  descriptors. Note that DSK
C                                  descriptors are not to be confused
C                                  with DLA descriptors, which contain
C                                  segment component base address and
C                                  size information.
C
C                       KWVTBD     Vertex bounds. This is an array of
C                                  six values giving the minimum and
C                                  maximum values of each component of
C                                  the vertex set.
C
C                       KWVXOR     Voxel grid origin. This is the
C                                  location of the voxel grid origin in
C                                  the body-fixed frame associated with
C                                  the target body.
C
C                       KWVXSZ     Voxel size.  DSK voxels are cubes;
C                                  the edge length of each cube is
C                                  given by the voxel size.  This
C                                  size applies to the fine voxel grid.
C                                  Units are km.
C
C
C     START          is the start index within specified data item from
C                    which data are to be fetched. The index of the
C                    first element of each data item is 1.
C
C     ROOM           is the amount of room in the output array.  It
C                    is permissible to provide an output array
C                    that has too little room to fetch an item in
C                    one call.
C
C$ Detailed_Output
C
C     N              is the number of elements fetched to the output
C                    array VALUES.  N is normally in the range
C                    1:ROOM; if an error occurs on the call, N is
C                    undefined.
C
C     VALUES         is a contiguous set of elements of the item
C                    designated by ITEM.  The correspondence of
C                    VALUES at the elements of the data item is:
C
C                       VALUES(1)      ITEM(START)
C                         ...             ...
C                       VALUES(N)      ITEM(START+N-1)
C
C                    If an error occurs on the call, VALUES is
C                    undefined.
C
C$ Parameters
C
C     See the INCLUDE files
C
C         dla.inc
C         dsk02.inc
C         dskdsc.inc
C
C$ Exceptions
C
C     1) If the input handle is invalid, the error will be diagnosed by
C        routines in the call tree of this routine.
C
C     2) If a file read error occurs, the error will be diagnosed by
C        routines in the call tree of this routine.
C
C     3) If the input DLA descriptor is invalid, the effect of this
C        routine is undefined. The error *may* be diagnosed by routines
C        in the call  tree of this routine, but there are no
C        guarantees.
C
C     4) If ROOM is non-positive, the error SPICE(VALUEOUTOFRANGE)
C        is signaled.
C
C     5) If the coarse voxel scale read from the designated segment
C        is less than 1, the error PICE(VALUEOUTOFRANGE) is signaled.
C
C     6) If the input keyword parameter is not recognized, the error
C        SPICE(NOTSUPPORTED) is signaled.
C
C     7) If START is less than 1 or greater than the size of the
C        item to be fetched, the error SPICE(INDEXOUTOFRANGE) is
C        signaled.
C
C$ Files
C
C     See input argument HANDLE.
C
C$ Particulars
C
C     Most SPICE applications will not need to call this routine. The
C     routines DSKV02, DSKP02, and DSKZ02 provide a higher-level
C     interface for fetching DSK type 2 vertex and plate data.
C
C     DSK files are built using the DLA low-level format and
C     the DAS architecture; DLA files are a specialized type of DAS
C     file in which data are organized as a doubly linked list of
C     segments.  Each segment's data belong to contiguous components of
C     character, double precision, and integer type.
C
C     Note that the DSK descriptor for the segment is not needed by
C     this routine; the DLA descriptor contains the base address and
C     size information for the integer, double precision, and character
C     components of the segment, and these suffice for the purpose of
C     fetching data.
C
C$ Examples
C
C     The numerical results shown for this example may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     1) Look up all the vertices associated with each plate
C        of the model contained in a specified type 2 segment.
C        For this example, we'll show the context of this look-up:
C        opening the DSK file for read access, traversing a trivial,
C        one-segment list to obtain the segment of interest.
C
C
C        Example code begins here.
C
C
C                 PROGRAM EX1
C                 IMPLICIT NONE
C
C                 INCLUDE 'dla.inc'
C                 INCLUDE 'dskdsc.inc'
C                 INCLUDE 'dsk02.inc'
C
C           C
C           C     Local parameters
C           C
C                 CHARACTER*(*)         FMT
C                 PARAMETER           ( FMT    = '(1X,A,3(1XE16.9))' )
C
C                 INTEGER               FILSIZ
C                 PARAMETER           ( FILSIZ = 255 )
C
C           C
C           C     Local variables
C           C
C                 CHARACTER*(FILSIZ)    DSK
C
C                 DOUBLE PRECISION      VRTCES ( 3, 3 )
C
C                 INTEGER               DLADSC ( DLADSZ )
C                 INTEGER               HANDLE
C                 INTEGER               I
C                 INTEGER               J
C                 INTEGER               N
C                 INTEGER               NP
C                 INTEGER               START
C                 INTEGER               VRTIDS ( 3 )
C
C                 LOGICAL               FOUND
C
C
C           C
C           C     Prompt for the name of the DSK to read.
C           C
C                 CALL PROMPT ( 'Enter DSK name > ', DSK )
C           C
C           C     Open the DSK file for read access.
C           C     We use the DAS-level interface for
C           C     this function.
C           C
C                 CALL DASOPR ( DSK, HANDLE )
C
C           C
C           C     Begin a forward search through the
C           C     kernel, treating the file as a DLA.
C           C     In this example, it's a very short
C           C     search.
C           C
C                 CALL DLABFS ( HANDLE, DLADSC, FOUND )
C
C                 IF ( .NOT. FOUND ) THEN
C           C
C           C        We arrive here only if the kernel
C           C        contains no segments.  This is
C           C        unexpected, but we're prepared for it.
C           C
C                    CALL SETMSG ( 'No segments found '
C                .   //            'in DSK file #.'    )
C                    CALL ERRCH  ( '#',  DSK           )
C                    CALL SIGERR ( 'SPICE(NODATA)'     )
C
C                 END IF
C
C           C
C           C     If we made it this far, DLADSC is the
C           C     DLA descriptor of the first segment.
C           C
C           C     Find the number of plates in the model.
C           C
C                 CALL DSKI02 ( HANDLE, DLADSC, KWNP, 1, 1, N, NP )
C
C           C
C           C     For each plate, look up the desired data.
C           C
C                 DO I = 1, NP
C           C
C           C        For the Ith plate, find the associated
C           C        vertex IDs.  We must take into account
C           C        the fact that each plate has three
C           C        vertices when we compute the start
C           C        index.
C           C
C                    START = 3*(I-1)+1
C
C                    CALL DSKI02 ( HANDLE, DLADSC, KWPLAT, START,
C                .                 3,      N,      VRTIDS        )
C
C                    DO J = 1, 3
C           C
C           C            Fetch the vertex associated with
C           C            the Jth vertex ID.  Again, each
C           C            vertex is a 3-vector.  Note that
C           C            the vertices are double-precision
C           C            data, so we fetch them using
C           C            DSKD02.
C           C
C                        START = 3*( VRTIDS(J) - 1 ) + 1
C
C                        CALL DSKD02 ( HANDLE, DLADSC, KWVERT,  START,
C                .                     3,      N,      VRTCES(1,J)    )
C                    END DO
C
C           C
C           C        Display the vertices of the Ith plate:
C           C
C                    WRITE (*,*) ' '
C                    WRITE (*,*) 'Plate number: ', I
C                    WRITE (*,FMT) '   Vertex 1: ', (VRTCES(J,1), J=1,3)
C                    WRITE (*,FMT) '   Vertex 2: ', (VRTCES(J,2), J=1,3)
C                    WRITE (*,FMT) '   Vertex 3: ', (VRTCES(J,3), J=1,3)
C
C                 END DO
C
C           C
C           C     Close the kernel.  This isn't necessary in a stand-
C           C     alone program, but it's good practice in subroutines
C           C     because it frees program and system resources.
C           C
C                 CALL DASCLS ( HANDLE )
C
C                 END
C
C
C     When this program was executed on a PC/Linux/gfortran/64bit
C     platform, using a DSK file representing a regular icosahedron,
C     the output was:
C
C
C      Enter DSK name > solid.bds
C
C       Plate number:            1
C          Vertex 1:   0.000000000E+00  0.000000000E+00  0.117557000E+01
C          Vertex 2:   0.105146000E+01  0.000000000E+00  0.525731000E+00
C          Vertex 3:   0.324920000E+00  0.100000000E+01  0.525731000E+00
C
C       Plate number:            2
C          Vertex 1:   0.000000000E+00  0.000000000E+00  0.117557000E+01
C          Vertex 2:   0.324920000E+00  0.100000000E+01  0.525731000E+00
C          Vertex 3:  -0.850651000E+00  0.618034000E+00  0.525731000E+00
C
C          ...
C
C       Plate number:           20
C          Vertex 1:   0.850651000E+00 -0.618034000E+00 -0.525731000E+00
C          Vertex 2:   0.000000000E+00  0.000000000E+00 -0.117557000E+01
C          Vertex 3:   0.850651000E+00  0.618034000E+00 -0.525731000E+00
C
C
C$ Restrictions
C
C     1) This routine uses discovery check-in to boost
C        execution speed.  However, this routine is in
C        violation of NAIF standards for use of discovery
C        check-in:  routines called from this routine may
C        signal errors.  If errors are signaled in called
C        routines, this routine's name will be missing
C        from the traceback message.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 04-FEB-2017 (NJB)
C
C        Fixed typo in version description.
C
C     23-AUG-2016
C
C        Now saves NV and updates it only when the current
C        segment changes.
C
C     15-JAN-2016 (NJB)
C
C        Removed code involving parameter NP.
C        Updated header Examples section.
C
C-    DSKLIB Version 3.0.0, 13-MAY-2010 (NJB)
C
C        Updated for compatibility with new DSK type 2
C        segment design.
C
C-    DSKLIB Version 2.1.0, 20-APR-2010 (NJB)
C
C        Bug fix: changed declaration of output argument
C        VALUES to double precision.
C
C-    DSKLIB Version 2.0.0, 27-DEC-2006 (NJB)
C
C        Updated to remove support for min, max radius
C        lookup.  These values are now stored in DSK
C        descriptors.
C
C-    DSKLIB Version 1.0.0, 27-OCT-2006 (NJB)
C
C-&

C$ Index_Entries
C
C     fetch d.p. data from a type 2 dsk segment
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               FAILED

C
C     Local parameters
C

C
C     Local variables
C
      INTEGER               B
      INTEGER               DBASE
      INTEGER               E
      INTEGER               IBASE
      INTEGER               NV
      INTEGER               PRVHAN
      INTEGER               PRVBAS
      INTEGER               SIZE

      LOGICAL               FIRST

C
C     Saved variables
C
      SAVE                  FIRST
      SAVE                  PRVBAS
      SAVE                  PRVHAN
      SAVE                  NV

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

C
C     Use discovery check-in.  This is done for efficiency; note
C     however that this routine does not meet SPICE standards for
C     discovery check-in eligibility.
C
      IF ( FIRST ) THEN
C
C        Make sure we treat the input handle as new on the first pass.
C        Set PRVHAN to an invalid handle value.
C
         PRVHAN = 0

C
C        Set previous segment base integer address to an invalid value
C        as well.
C
         PRVBAS = -1

         FIRST  = .FALSE.

      END IF

      IF ( ROOM .LE. 0 ) THEN

         CALL CHKIN  ( 'DSKD02' )
         CALL SETMSG ( 'ROOM was #; must be positive.' )
         CALL ERRINT ( '#',  ROOM                      )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'        )
         CALL CHKOUT ( 'DSKD02'                        )
         RETURN

      END IF

      IBASE  = DLADSC ( IBSIDX )
      DBASE  = DLADSC ( DBSIDX )

C
C     Either a new file or new segment in the same file will require
C     looking up the segment parameters. To determine whether the
C     segment is new, we don't need to compare the entire DLA
C     descriptor: just comparing the integer base address of the
C     descriptor against the saved integer base address is sufficient.
C
C     DSK type 2 segments always have a non-empty integer component, so
C     each type 2 segment in a given file will have a distinct integer
C     base address. Segments of other types might not contain integers,
C     but they can't share an integer base address with a type 2
C     segment.
C
      IF (      ( HANDLE .NE. PRVHAN )
     .     .OR. ( IBASE  .NE. PRVBAS )  ) THEN
C
C        Treat the input file and segment as new.
C
C        Read NV.
C
         CALL DASRDI ( HANDLE, IBASE+IXNV, IBASE+IXNV, NV )

         IF ( FAILED() ) THEN
            RETURN
         END IF
C
C        Update the saved handle value.
C
         PRVHAN = HANDLE

C
C        Update the saved integer base address.
C
         PRVBAS = IBASE

      END IF

C
C     Branch based on the item to be returned.
C
C     Note that we haven't checked the validity of START; we'll do this
C     after the IF block.
C
      IF ( ITEM .EQ. KWVERT ) THEN
C
C        Return vertices.  There are 3*NV values in all.
C        First locate the data.
C
         SIZE =   3*NV
         B    = ( DBASE + IXVERT ) + START - 1

      ELSE IF ( ITEM .EQ. KWDSC ) THEN
C
C        Return DSK descriptor.
C
         SIZE =   DSKDSZ
         B    = ( DBASE + IXDSCR ) + START - 1

      ELSE IF ( ITEM .EQ. KWVTBD ) THEN
C
C        Return vertex bounds.  There are 6 elements.
C
         SIZE =   6
         B    = ( DBASE + IXVTBD ) + START - 1

      ELSE IF ( ITEM .EQ. KWVXOR ) THEN
C
C        Return voxel grid origin.  There are 3 elements.
C
         SIZE =   3
         B    = ( DBASE + IXVXOR ) + START - 1

      ELSE IF ( ITEM .EQ. KWVXSZ ) THEN
C
C        Return voxel size.  This is a scalar.
C
         SIZE =   1
         B    = ( DBASE + IXVXSZ ) + START - 1

      ELSE

         CALL CHKIN  ( 'DSKD02' )
         CALL SETMSG ( 'Keyword parameter # was not recognized.' )
         CALL ERRINT ( '#',  ITEM                                )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'                     )
         CALL CHKOUT ( 'DSKD02'                                  )
         RETURN

      END IF

C
C     The valid range for START is 1:SIZE.
C
      IF (  ( START .LT. 1 ) .OR. ( START .GT. SIZE )  ) THEN

         CALL CHKIN  ( 'DSKD02' )
         CALL SETMSG ( 'START must be in the range defined ' //
     .                 'by the size of the data associated ' //
     .                 'with the keyword parameter #, '      //
     .                 'namely 1:#.  Actual value of START ' //
     .                 'was #.'                              )
         CALL ERRINT ( '#',  ITEM                            )
         CALL ERRINT ( '#',  SIZE                            )
         CALL ERRINT ( '#',  START                           )
         CALL SIGERR ( 'SPICE(INDEXOUTOFRANGE)'              )
         CALL CHKOUT ( 'DSKD02'                              )
         RETURN

      END IF

C
C     Read the requested data.  We already have the start address B.
C
      N  =   MIN ( ROOM, SIZE - START + 1 )
      E  =   B + N - 1

      CALL DASRDD ( HANDLE, B, E, VALUES )

      RETURN
      END


text:
Subroutine resdec(i1, nt, nnn, wid, idecay, ipion)
  Parameter (hbarc=0.19733)
  Parameter (ak0=0.498, apich=0.140, api0=0.135, an=0.940, addm=0.02)
  Parameter (maxstr=150001, maxr=1)
  Common /input2/ilab, manyb, ntmax, icoll, insys, ipot, mode, imomen, nfreq, icflow, icrho, icou, kpoten, kmul
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Common /ludat3/mdcy(500, 3), mdme(2000, 2), brat(2000), kfdp(2000, 5)
  Common /cc/e(maxstr)
  Common /ee/id(maxstr), lb(maxstr)
  Common /pa/rpion(3, maxstr, maxr)
  Common /pb/ppion(3, maxstr, maxr)
  Common /pc/epion(maxstr, maxr)
  Common /pd/lpion(maxstr, maxr)
  Common /input1/masspr, massta, iseed, iavoid, dt
  Common /resdcy/nsav, iksdcy
  Common /leadng/lb1, px1, py1, pz1, em1, e1, xfnl, yfnl, zfnl, tfnl, px1n, py1n, pz1n, dp1n
  External iarflv, invflv
  Common /tdecay/tfdcy(maxstr), tfdpi(maxstr, maxr), tft(maxstr)
  Common /rndf77/nseed
  Common /dpert/dpertt(maxstr, maxr), dpertp(maxstr), dplast(maxstr), dpdcy(maxstr), dpdpi(maxstr, maxr), dpt(maxstr, maxr), dpp1(maxstr, maxr), dppion(maxstr, maxr)
  Common /phidcy/iphidcy, pttrig, ntrig, maxmiss, ipi0dcy
  Save
  irun = idecay
  If (nt==ntmax .And. ipi0dcy==1 .And. ((lb1==4 .And. ipion==0) .Or. ipion>=1)) Then
     kf = 111
  Else If (lb1==0 .Or. lb1==25 .Or. lb1==26 .Or. lb1==27 .Or. lb1==28 .Or. lb1==29 .Or. iabs(lb1)==30 .Or. lb1==24 .Or. (iabs(lb1)>=6 .And. iabs(lb1)<=9) .Or. iabs(lb1)==16) Then
     kf = invflv(lb1)
  Else
     Return
  End If
  ip = 1
  n = 1
  k(ip, 1) = 1
  k(ip, 3) = 0
  k(ip, 4) = 0
  k(ip, 5) = 0
  k(ip, 2) = kf
  If (ipion==0) Then
     p(ip, 1) = px1
     p(ip, 2) = py1
     p(ip, 3) = pz1
     If ((lb1==0 .Or. lb1==28) .And. em1<(2*apich+api0+addm)) Then
        em1 = 2*apich + api0 + addm
     Else If (lb1>=25 .And. lb1<=27 .And. em1<(2*apich+addm)) Then
        em1 = 2*apich + addm
     Else If (iabs(lb1)==30 .And. em1<(apich+ak0+addm)) Then
        em1 = apich + ak0 + addm
     Else If (iabs(lb1)>=6 .And. iabs(lb1)<=9 .And. em1<(apich+an+addm)) Then
        em1 = apich + an + addm
     End If
     e1 = sqrt(em1**2+px1**2+py1**2+pz1**2)
     p(ip, 4) = e1
     p(ip, 5) = em1
     dpdecp = dpertp(i1)
  Else If (nt==ntmax .And. ipi0dcy==1 .And. ipion>=1) Then
     p(ip, 1) = ppion(1, ipion, irun)
     p(ip, 2) = ppion(2, ipion, irun)
     p(ip, 3) = ppion(3, ipion, irun)
     p(ip, 5) = epion(ipion, irun)
     p(ip, 4) = sqrt(p(ip,5)**2+p(ip,1)**2+p(ip,2)**2+p(ip,3)**2)
     dpdecp = dppion(ipion, irun)
  Else
     Print *, 'stopped in resdec() a'
     Stop
  End If
  Call ludecy(ip)
  If (nt==ntmax) Then
     tau0 = hbarc/wid
     taudcy = tau0*(-1.)*alog(1.-ranart(nseed))
     ndaut = n - nsav
     If (ndaut<=1) Then
        Write (10, *) 'note: ndaut(<1)=', ndaut
        Call lulist(2)
        Stop
     End If
     If (ipion==0) Then
        taudcy = taudcy*e1/em1
        tfnl = tfnl + taudcy
        xfnl = xfnl + px1/e1*taudcy
        yfnl = yfnl + py1/e1*taudcy
        zfnl = zfnl + pz1/e1*taudcy
     Else If (ipion>=1) Then
        taudcy = taudcy*p(ip, 4)/p(ip, 5)
        tfnl = tfdpi(ipion, irun) + taudcy
        xfnl = rpion(1, ipion, irun) + p(ip, 1)/p(ip, 4)*taudcy
        yfnl = rpion(2, ipion, irun) + p(ip, 2)/p(ip, 4)*taudcy
        zfnl = rpion(3, ipion, irun) + p(ip, 3)/p(ip, 4)*taudcy
     Else
        Print *, 'stopped in resdec() b', ipion, wid, p(ip, 4)
        Stop
     End If
     If (n>=(nsav+2) .And. ipion==0) Then
        Do idau = nsav + 2, n
           kdaut = k(idau, 2)
           If (kdaut==221 .Or. kdaut==113 .Or. kdaut==213 .Or. kdaut==-213 .Or. kdaut==310) Then
              ksave = kdaut
              pxsave = p(idau, 1)
              pysave = p(idau, 2)
              pzsave = p(idau, 3)
              esave = p(idau, 4)
              xmsave = p(idau, 5)
              k(idau, 2) = k(nsav+1, 2)
              p(idau, 1) = p(nsav+1, 1)
              p(idau, 2) = p(nsav+1, 2)
              p(idau, 3) = p(nsav+1, 3)
              p(idau, 4) = p(nsav+1, 4)
              p(idau, 5) = p(nsav+1, 5)
              k(nsav+1, 2) = ksave
              p(nsav+1, 1) = pxsave
              p(nsav+1, 2) = pysave
              p(nsav+1, 3) = pzsave
              p(nsav+1, 4) = esave
              p(nsav+1, 5) = xmsave
              Goto 111
           End If
        End Do
     End If
111  Continue
     enet = 0.
     Do idau = nsav + 1, n
        enet = enet + p(idau, 4)
     End Do
  End If
  Do idau = nsav + 1, n
     kdaut = k(idau, 2)
     lbdaut = iarflv(kdaut)
     If (nt==ntmax .And. (kdaut==130 .Or. kdaut==310 .Or. iabs(kdaut)==311)) Then
        If (kdaut==130) Then
           lbdaut = 22
        Else If (kdaut==310) Then
           lbdaut = 24
        Else If (iabs(kdaut)==311) Then
           If (ranart(nseed)<0.5) Then
              lbdaut = 22
           Else
              lbdaut = 24
           End If
        End If
     End If
     If (idau==(nsav+1)) Then
        If (ipion==0) Then
           lb(i1) = lbdaut
           e(i1) = p(idau, 5)
           px1n = p(idau, 1)
           py1n = p(idau, 2)
           pz1n = p(idau, 3)
           dp1n = dpdecp
        Else If (ipion>=1) Then
           lpion(ipion, irun) = lbdaut
           epion(ipion, irun) = p(idau, 5)
           ppion(1, ipion, irun) = p(idau, 1)
           ppion(2, ipion, irun) = p(idau, 2)
           ppion(3, ipion, irun) = p(idau, 3)
           rpion(1, ipion, irun) = xfnl
           rpion(2, ipion, irun) = yfnl
           rpion(3, ipion, irun) = zfnl
           tfdpi(ipion, irun) = tfnl
           dppion(ipion, irun) = dpdecp
        End If
     Else
        nnn = nnn + 1
        lpion(nnn, irun) = lbdaut
        epion(nnn, irun) = p(idau, 5)
        ppion(1, nnn, irun) = p(idau, 1)
        ppion(2, nnn, irun) = p(idau, 2)
        ppion(3, nnn, irun) = p(idau, 3)
        rpion(1, nnn, irun) = xfnl
        rpion(2, nnn, irun) = yfnl
        rpion(3, nnn, irun) = zfnl
        tfdpi(nnn, irun) = tfnl
        dppion(nnn, irun) = dpdecp
     End If
  End Do
  Return
End Subroutine resdec

max_stars_repo_name: xiaohaijin/AMPT

max_issues_repo_name: xiaohaijin/AMPT

max_forks_repo_name: xiaohaijin/AMPT


text:
C    @(#)shellsrt.f	20.3 2/13/96
        subroutine shellsrt (m, n, kompar, swap)

        external kompar, swap

        integer kompar
        logical sorted, done

        sorted = .false.
        level = 0

        do while (.not.sorted)
           num = n - m + 1
           do while (num .gt. 1)
              num = num / 2
              k = n - num
              j = m
              do while (j .le. k)
                 i = j
                 done = .false.
                 do while ( i .ge. m  .and.  .not. done )
                    if (kompar(i,i+num) .gt. 0) then
                       call swap(i,i+num)
                       i = i - num
                    else
                       done = .true.
                    endif
                 enddo
                 j = j + 1
              enddo
           enddo
           sorted = .true.
        end do
        return
        end

ext: f

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
subroutine sld_memallGeneral(a)
   !-----------------------------------------------------------------------
   !****f* SOLIDS/sld_memall
   ! NAME
   !    sld_memall
   ! DESCRIPTION
   !    This routine allocates memory for the arrays needed to solve the problem
   !-----------------------------------------------------------------------
   use typre
   use Mod_Memor
   use Mod_Element
   use Mod_TimeIntegrator
   use Mod_Solids
   implicit none

   class(SolidsProblem)          :: a
   type(TimeIntegratorDt2)       :: Integrator
   class(FiniteElement), pointer :: e => NULL()
   integer(ip) :: nsteps,ndime,npoin,pgaus,nelem,ncomp,sz,ielem,pnode

   !Unknowns
   call a%Mesh%GetNdime(ndime)
   call a%Mesh%GetNpoin(npoin)
   call a%Mesh%GetNelem(nelem)

   sz = (ndime*(ndime+1))/2

   call Integrator%Init(a%kfl_tsche_2nd_datafile)
   call Integrator%GetNumberOfTimeSteps(nsteps)

   a%ncomp = nsteps + 1
   ncomp = a%ncomp

   call a%Memor%alloc(ndime,npoin,ncomp,a%disp, 'disp','sld_memall')

   if(a%kfl_NodalStress) call a%Memor%alloc(sz   ,npoin  ,a%stress,'stress','sldsup_memall')
   if(a%kfl_NodalStrain) call a%Memor%alloc(sz   ,npoin  ,a%strain,'strain','sldsup_memall')

   call a%Memor%alloc(ndime,npoin,a%btraction_nodal, 'Bnodaltraction','sld_memall')

   if(a%kfl_docoupconv) then
       call a%Memor%alloc(ndime,npoin,a%disp_cp, 'disp_cp','sld_memall')
   endif

   if (a%kfl_timei==1) then
       call a%Memor%alloc(ndime,npoin,2,a%veloc,'veloc','sld_memall')
       call a%Memor%alloc(ndime,npoin,2,a%accel,'accel','sld_memall')
   end if

   call a%Memor%alloc(nelem,a%extForce,'extForce','sld_memall')
   if(a%kfl_printStress) call a%Memor%alloc(nelem,a%stress_g,'stress_g','sld_memall')
   if(a%kfl_printStrain) call a%Memor%alloc(nelem,a%strain_g,'strain_g','sld_memall')
   call a%Memor%alloc(nelem,a%btraction,'btraction','sld_memall')

   call a%Mesh%ElementAlloc(e,a%Memor,'DefaultRule','sld_memall')

   do ielem=1,nelem
       call a%Mesh%GetElemArraySize(ielem,pnode,pgaus)

       call a%Mesh%ElementLoad(ielem,e)
       allocate(a%extForce(ielem)%a(a%ndofn,e%mnode))

       if(a%kfl_printStress) then
           allocate(a%stress_g(ielem)%a(sz,pgaus))
           a%stress_g(ielem)%a  = 0.0_rp
       endif

       if(a%kfl_printStrain) then
           allocate(a%strain_g(ielem)%a(sz,pgaus))
           a%strain_g(ielem)%a  = 0.0_rp
       endif

       allocate(a%btraction(ielem)%a(ndime,pgaus))

       a%extForce(ielem)%a  = 0.0_rp
       a%btraction(ielem)%a = 0.0_rp

   end do

   call a%Mesh%ElementDeAlloc(e,a%Memor,'DefaultRule','sld_memall')

   call a%SolidSpecificMemall

end subroutine sld_memallGeneral

subroutine sld_memallSpecific(a)
   !-----------------------------------------------------------------------
   !****f* SOLIDS/sld_memall
   ! NAME
   !    sld_memall
   ! DESCRIPTION
   !    This routine allocates memory for the arrays needed to solve the problem
   !-----------------------------------------------------------------------
   use typre
   use Mod_Memor
   use Mod_Element
   use Mod_TimeIntegrator
   use Mod_Solids
   implicit none

   class(SolidsProblem)          :: a
   class(FiniteElement), pointer :: e => NULL()
   integer(ip) :: nsteps,ndime,npoin,pgaus,nelem,sz,ielem,pnode

   !Unknowns
   call a%Mesh%GetNdime(ndime)
   call a%Mesh%GetNpoin(npoin)
   call a%Mesh%GetNelem(nelem)

   sz = (ndime*(ndime+1))/2

   if(a%kfl_printNodalSigma) call a%Memor%alloc(sz   ,npoin,1,a%sigma,'sigma','sld_memall')
   if(a%kfl_printNodalPress) call a%Memor%alloc(      npoin,1,a%press,'press','sld_memall')

   if(a%kfl_printGaussSigma) call a%Memor%alloc(nelem,a%sigma_g,'sigma_g','sldup_memall')
   if(a%kfl_printGaussPress) call a%Memor%alloc(nelem,a%press_g,'press_g','sldup_memall')

   call a%Memor%alloc(sz,sz,a%c_elastic,   'c_elastic','sld_memall')

   call a%Memor%alloc(nelem,a%pStrain,'pStrain','sld_memall')

   if(a%kfl_printPrincipalStresses) then
       call a%Memor%alloc(nelem,a%printPStrain,'printPStrain','sld_memall')
   end if

   call a%Mesh%ElementAlloc(e,a%Memor,'DefaultRule','sld_memall')

   do ielem=1,nelem
       call a%Mesh%GetElemArraySize(ielem,pnode,pgaus)

       call a%Mesh%ElementLoad(ielem,e)

       allocate(a%pStrain(ielem)%a(ndime))
       a%pStrain(ielem)%a   = 0.0_rp

       if(a%kfl_printPrincipalStresses) then
           allocate(a%printPStrain(ielem)%a(sz,pgaus))
           a%printPStrain(ielem)%a = 0.0_rp
       end if

       if (a%kfl_printGaussPress) then
         allocate(a%press_g(ielem)%a(pgaus))
         a%press_g(ielem)%a  = 0.0_rp
       endif

       if (a%kfl_printGaussSigma) then
           allocate(a%sigma_g(ielem)%a(sz,pgaus))
           a%sigma_g(ielem)%a  = 0.0_rp
       endif

   end do

   call a%Mesh%ElementDeAlloc(e,a%Memor,'DefaultRule','sld_memall')

end subroutine sld_memallSpecific

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.02/11                           *
C  *    TEST TITLE : Visual effect of modelling clipping   *
C  *                 facilities                            *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      COMMON /DIALOG/ DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT,
     2                DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS
      INTEGER         DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT
      REAL            DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS

C aspect source
C                bundled     individual
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)
C clipping indicator
C                noclip      clip
      INTEGER    PNCLIP,     PCLIP
      PARAMETER (PNCLIP = 0, PCLIP = 1)
C modelling clipping operator
      INTEGER    PMCREP,     PMCINT
      PARAMETER (PMCREP = 1, PMCINT = 2)
C edit mode
      INTEGER    PINSRT,     PREPLC
      PARAMETER (PINSRT = 0, PREPLC = 1)
C composition type
C                preconcatenate  postconcatenate  replace
      INTEGER    PCPRE,          PCPOST,          PCREPL
      PARAMETER (PCPRE = 0,      PCPOST = 1,      PCREPL = 2)
C text precision
      INTEGER    PSTRP,     PCHARP,     PSTRKP
      PARAMETER (PSTRP = 0, PCHARP = 1, PSTRKP = 2)
C text alignment horizontal
      INTEGER    PAHNOR,     PALEFT,     PACENT,     PARITE
      PARAMETER (PAHNOR = 0, PALEFT = 1, PACENT = 2, PARITE = 3)
C text alignment vertical
      INTEGER    PAVNOR,     PATOP,      PACAP,     PAHALF,
     1           PABASE,     PABOTT
      PARAMETER (PAVNOR = 0, PATOP  = 1, PACAP = 2, PAHALF = 3,
     1           PABASE = 4, PABOTT = 5)

C maximum number of planes to be tested
      INTEGER    TSTMAX
      PARAMETER (TSTMAX = 500)

      REAL       PI
      PARAMETER (PI = 3.14159265)

      INTEGER    PICSTR, TXCI, IX, MAXPL, I, MCLPOP,  NLRMCT, LRMCOP(50)
      INTEGER    NOL, NLIMCT,  LIMCOP(50), VISCT, LISOP(6),NMCLHS
      INTEGER    NUMPL, MINMRK, MAXMRK, RNDINT, NSIZ
      INTEGER    IDUM1, IDUM2, IDUM3, IDUM4, NUMOP

      REAL       RAD, ANG, COSANG, SINANG, MC2D(4,1)
      REAL       HS(6,TSTMAX), RNDRL, X(15),Y(15), RDUM1, RDUM2
      REAL       IDXF(4,4), XF(4,4), NOMMS, MSCF

      LOGICAL    DYN

      CHARACTER  TXSTR*23, THISOP*3

      CALL INITGL ('06.01.02/11')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)
C set-up of workstation and dialogue area
      PICSTR = 101
      TXCI = 1
      CALL SETDLG (PICSTR, 801,TXCI)

      CALL POPST (PICSTR)
C  by convention, view #1 is for picture
      CALL PSVWI (1)
C  use individual attributes
      CALL SETASF (PINDIV)
C
C  adjust polymarker size
      CALL PQPMF (SPECWT, 0, ERRIND, IDUM1,IDUM2,IDUM3, NOMMS, RDUM1,
     1            RDUM2, IDUM4)
      CALL CHKINQ ('pqpmf', ERRIND)
      MSCF = .02 / (NOMMS*WCPDC)
      CALL PSMKSC (MSCF)

      CALL PEXST(102)
      CALL PCLST
      CALL POPST(102)

C    <inquire modelling clipping facilities> to determine
C      maxpl  = maximum# of planes
C      NOL    = # of operators
      CALL  PQMCLF (0, ERRIND, MAXPL, NOL, MCLPOP)
      CALL  CHKINQ ('pqmclf', ERRIND)

C    lrmcop = list of registered modelling clipping combination
C             operators > 2
C    limcop = list of implementor modelling clipping combination
C             operators < 1
      NLIMCT = 0
      NLRMCT = 0
      DO 100 I=1,NOL
         CALL PQMCLF ( I, ERRIND, NMCLHS, NOL, MCLPOP )
         CALL CHKINQ ('pqmclf', ERRIND)

         IF ( MCLPOP .GT. 2) THEN
            NLRMCT = NLRMCT + 1
            LRMCOP(NLRMCT) = MCLPOP
         ELSE IF ( MCLPOP .LT. 1) THEN
            NLIMCT = NLIMCT + 1
            LIMCOP(NLIMCT) = MCLPOP
         ENDIF
100   CONTINUE

C  *** *** ***  Specified volume with Max Planes  *** *** ***

C  numpl = actual number of planes to be tested
C  minmrk = minimum number of visible markers = 2
C  maxmrk = maximum number of visible markers = min(12, 0.75*numpl)
C  rad = WC radius of prism = 0.4
      NUMPL = MIN(MAXPL,TSTMAX)
      MINMRK = 2
      MAXMRK = MIN(12, (3*NUMPL)/4)
      RAD = 0.4

      CALL SETMSG ('23 35 40 41 42 43 59', 'The program should be '   //
     1             'able to replace the current modelling clipping '  //
     2             'volume by a specified modelling clipping volume ' //
     3             'that uses up to the reported maximum number of '  //
     4             'distinct planes.')

C  set local transformation:
      CALL EBLTM3 (0.,0.,0., 0.5,0.5,0.5, PI/2.,0.,0., RAD,RAD,RAD, XF)
      CALL PSLMT3 (XF,PCREPL)

      DO 110 IX = 1,NUMPL
         ANG = IX*2*PI / NUMPL
         COSANG = COS(ANG)
         SINANG = SIN(ANG)

         HS(1,IX) = COSANG
         HS(2,IX) = RNDRL(-5.,5.)
         HS(3,IX) = SINANG
         HS(4,IX) = -COSANG
         HS(5,IX) = 0.
         HS(6,IX) = -SINANG
  110 CONTINUE

C  set up current MCV to be replaced by next <Set MCV>:
      MC2D(1,1) = -.5
      MC2D(2,1) = 0.0
      MC2D(3,1) = 1.
      MC2D(4,1) = 0.
      CALL PSMCV ( PMCREP, 1, MC2D )

C  set 3D MCV
      CALL PSMCV3 ( PMCREP, NUMPL, HS )

C  set local transformation back to identity
      CALL IDMAT (4,IDXF)
      CALL PSLMT3 (IDXF,PCREPL)

C  set modelling clipping indicator = CLIP
      CALL PSMCLI ( PCLIP )

C  number of unclipped markers
      VISCT = RNDINT(MINMRK,  MAXMRK)

      CALL CLPGON (VISCT,NUMPL,RAD)

      CALL DCHPFV ('MAXIMUM NUMBER OF SPECIFIED DISTINCT PLANES: ' //
     1             'How many markers are visible?', NUMPL, VISCT)

C  *** *** ***  Current volume with Max Planes  *** *** ***

      CALL PEMST (102)

      CALL SETMSG ('23 35 40 41 42 43 59', 'The intersection '       //
     1             'operator should be able to construct a current ' //
     2             'modelling clipping volume that uses up to the '  //
     3             'reported maximum number of distinct planes.')

C  set local transformation:
      CALL PSLMT3 (XF,PCREPL)

C  construct current MCV
      DO 130 IX = 1,NUMPL
         CALL PSMCV3 ( PMCINT, 1, HS(1,IX) )
  130 CONTINUE

C  set local transformation back to identity
      CALL IDMAT (4,IDXF)
      CALL PSLMT3 (IDXF,PCREPL)
C  set modelling clipping indicator = CLIP
      CALL PSMCLI ( PCLIP )
C  number of unclipped markers
      VISCT = RNDINT(MINMRK,  MAXMRK)

      CALL CLPGON (VISCT,NUMPL,RAD)

      CALL DCHPFV ('MAXIMUM NUMBER OF CURRENT DISTINCT PLANES: ' //
     1             'How many markers are visible?', NUMPL, VISCT)

C  *** *** *** implementor defined or registered operators   *** *** ***
      IF ((NLRMCT .EQ. 0) .AND. ( NLIMCT .EQ. 0)) THEN
         CALL INMSG ('No registered or implementor defined '    //
     1               'combination operators are supported for ' //
     2               'setting modelling clipping volume.')
         GOTO 170
      ENDIF

      CALL PEMST (102)

      TXSTR = 'WHERE''S THE REST OF ME?'

C  Set up four square areas
      CALL PSPLCI (3)
      CALL SETRVS ('.01,.01,.99,.99,.01', X, NSIZ)
      CALL SETRVS ('.01,.99,.99,.01,.01', Y, NSIZ)
      CALL PPL (NSIZ, X,Y)

C  Cross
      X(1) = 0.5
      Y(1) = 0.99
      X(2) = 0.5
      Y(2) = 0.01
      CALL PPL (2,X,Y)
      X(1) = 0.01
      Y(1) = 0.5
      X(2) = 0.99
      Y(2) = 0.5
      CALL PPL (2,X,Y)

C  Label each quadrant
      CALL VISLAB ('inside previous MCV',  'L', 0.03,.3,.9, .95)
      CALL VISLAB ('outside new MCV',      'L', 0.03,.3,.85,.9)
      CALL VISLAB ('outside previous MCV', 'L', 0.53,.8,.9, .95)
      CALL VISLAB ('outside new MCV',      'L', 0.53,.8,.85,.9)
      CALL VISLAB ('inside previous MCV',  'L', 0.03,.3,.08,.13)
      CALL VISLAB ('inside new MCV',       'L', 0.03,.3,.03,.08)
      CALL VISLAB ('outside previous MCV', 'L', 0.53,.8,.08,.13)
      CALL VISLAB ('inside new MCV',       'L', 0.53,.8,.03,.08)

C  set previous MCV
      MC2D(1,1) = 0.5
      MC2D(2,1) = 0.5
      MC2D(3,1) = -1.
      MC2D(4,1) = 0.
      CALL PSMCV ( PMCREP, 1, MC2D )
C  label element 101
      CALL PLB (101)
C  set dummy MCV
      CALL PSMCV ( PMCREP, 1, MC2D )
C  set clipping on
      CALL PSMCLI ( PCLIP )

C  text centered at 0.5,0.5
      CALL PSCHH  (0.03)
      CALL PSTXAL (PACENT,PAHALF)
      CALL PSTXFN (1)
      CALL PSTXPR (PSTRKP)
      CALL PTX (0.5,0.5, TXSTR)

C Position element pointer at  top
      CALL PSEP (1)
C  edit mode = replace
      CALL PSEDM (PREPLC)
C  position element pointer at label 101
      CALL PSEPLB (101)
C  increment element pointer by 1 to allow replacement
C     of second <set MCV>
      CALL POSEP (1)
C  clipping plane for operator to be tested
      MC2D(1,1) = 0.5
      MC2D(2,1) = 0.5
      MC2D(3,1) = 0.
      MC2D(4,1) = -1.0

C  *** *** *** *** Registered Operators  *** *** *** ***

      IF (NLRMCT .EQ. 0) THEN
         CALL INMSG ('No registered combination operators ' //
     1               'are supported for setting modelling ' //
     2               'clipping volume.')
         GOTO 160
      ENDIF

      CALL SETMSG ('35 40 44 57', 'The effect of combination '  //
     1             'operators > 2 in <set modelling clipping '  //
     2             'volume> should be as described in the ISO ' //
     3             'register.')

      NUMOP = MIN(NLRMCT, 8)
      CALL RNSET (NUMOP,NLRMCT,LISOP)
      DO 150 I=1,NUMOP
         CALL PSMCV ( LRMCOP(LISOP(I)), 1, MC2D )
         WRITE (THISOP, '(I3)') LRMCOP(LISOP(I))

         IF (.NOT. DYN ('REGISTERED OPERATORS: Is the clipping of ' //
     1                  'the centered text primitive "' // TXSTR    //
     2                  '" consistent with the description of '     //
     3                  'combination operator #' // THISOP          //
     4                  ', as documented in the ISO register?')) THEN
            CALL FAIL
            GOTO 160
         ENDIF
150   CONTINUE
      CALL PASS

160   CONTINUE

C  *** *** *** Implementor-defined Operators *** *** ***

      IF (NLIMCT .EQ. 0) THEN
           CALL INMSG ('No implementor-defined combination '  //
     1                 'operators are supported for setting ' //
     2                 'modelling clipping volume.')
         GOTO 170
      ENDIF
C
      CALL SETMSG ('35 40 45 57', 'The effect of combination '  //
     1             'operators < 1 in <set modelling clipping '  //
     2             'volume> should be as described in the '     //
     3             'implementor''s documentation.')

      NUMOP = MIN(NLIMCT, 8)
      CALL RNSET (NUMOP,NLIMCT,LISOP)
      DO 180 I=1,NUMOP
         CALL PSMCV ( LIMCOP(LISOP(I)), 1, MC2D )
         WRITE (THISOP, '(I3)') LIMCOP(LISOP(I))

         IF (.NOT. DYN ('IMPLEMENTATION OPERATORS: Is the clipping ' //
     1                  'of the centered text primitive "' // TXSTR  //
     2                  '" consistent with the description of '     //
     3                  'combination operator #' // THISOP          //
     4                  ', as documented by the implementor?')) THEN
            CALL FAIL
            GOTO 170
         ENDIF
180   CONTINUE
      CALL PASS

170   CONTINUE
C  wrap it up.
      CALL ENDIT
      END


text:
!> @file
!! Define operations on enumerators
!! @author
!!    Copyright (C) 2014-2015 BigDFT group
!!    This file is distributed under the terms of the
!!    GNU General Public License, see ~/COPYING file
!!    or http://www.gnu.org/copyleft/gpl.txt .
!!    For the list of contributors, see ~/AUTHORS
!! @usage
!!type(f_enumerator) :: primates=f_enumerator('PRIMATE',PRIMATE_INT,null()) !define the concept of primates
!!type(f_enumerator) :: monkey=f_enumerator('MONKEY',MONKEY_INT,null()) !define the monkeys
!!type(f_enumerator) :: man=f_enumerator('MAN',MAN_INT,null()) !define the man
!!
!!!the man is also a primate
!!call f_enum_attr(man,primates)
!!!as well as the monkey
!!call f_enum_attr(monkey,primates)
!!
!!!we now have as a variable the following enumerator:
!!type(f_enumerator) :: specimen
!!!which have been inutuialized somehow
!!
!!!usual usage of a flag
!!select case(str(speciment))
!!case('MAN')
!!!etc etc
!!case('MONKEY')
!!!etc !etc
!!end select
!!
!!!otherwise we might define an action that is executed either for monkey and man
!!if (specimen .hasattr. primates) then
!!!this source section is executed either for man and monkey case
!!end if
module f_enums
  implicit none

  private

  integer, parameter, private :: NULL_INT=-1024
  character(len=*), parameter, private :: null_name='nullified enumerator'

  !> enumerator type, useful to define different modes
  type, public :: f_enumerator
     character(len=64) :: name=null_name
     integer :: id=null_int
     type(f_enumerator), pointer :: family => null()
  end type f_enumerator

  type(f_enumerator), parameter, private :: &
       f_enum_null=f_enumerator(null_name,NULL_INT,null())

  interface operator(==)
     module procedure enum_is_enum,enum_is_char,enum_is_int, int_is_enum
  end interface operator(==)

  interface operator(/=)
     module procedure enum_is_not_enum,enum_is_not_char,enum_is_not_int
  end interface operator(/=)

  interface operator(.hasattr.)
     module procedure enum_has_attribute,enum_has_char,enum_has_int
  end interface operator(.hasattr.)

  interface operator(.getattr.)
     module procedure enum_get_from_int,enum_get_from_enum,enum_get_from_char
  end interface operator(.getattr.)

  interface toi
     module procedure int_enum
  end interface toi

  interface toa
     module procedure char_enum
  end interface toa

  public :: f_enum_attr,operator(.hasattr.),nullify_f_enum,f_enum_update
  public :: toi,toa,f_enumerator_null,operator(==),operator(/=),operator(.getattr.)

contains

  pure subroutine nullify_f_enum(en)
    implicit none
    type(f_enumerator), intent(out) :: en
    en=f_enumerator_null()
  end subroutine nullify_f_enum

  pure function f_enumerator_null() result(en)
    use yaml_strings, only: f_strcpy
    implicit none
    type(f_enumerator) :: en
    call f_strcpy(src=null_name,dest=en%name)
    en%id=null_int
    nullify(en%family)
  end function f_enumerator_null

  !>associate the enumerator to a family
  subroutine f_enum_attr(dest,attr)
    implicit none
    type(f_enumerator), intent(inout), target :: attr !< to avoid the parameter attribute
    type(f_enumerator), intent(inout) :: dest
    !local variables
    type(f_enumerator), pointer :: iter
    !print *,'ASSOCIATING',trim(char(dest)),trim(char(attr))
    !search the first iterator that has no family
    if (.not. associated(dest%family)) then
       !print *,'here'
       dest%family=>attr
    else
       !print *,'there'
       !if the enumerator already exists do not associate
       iter => dest%family
       do while(associated(iter%family) .and. (iter /= attr))
          iter => iter%family
       end do
       if (iter /= attr) iter%family=>attr
    end if
  end subroutine f_enum_attr

  function enum_get_from_int(en,family) result(iter)
    implicit none
    integer, intent(in) :: family

    type(f_enumerator), intent(in) :: en
    type(f_enumerator), pointer :: iter
    !local variables
    logical :: ok
    ok=.false.
    iter=>en%family
    do while(associated(iter))
       ok= iter == family
       if (ok) exit
       iter => iter%family
    end do

  end function enum_get_from_int

  function enum_get_from_char(en,family) result(iter)
    implicit none
    character(len=*), intent(in) :: family

    type(f_enumerator), intent(in) :: en
    type(f_enumerator), pointer :: iter
    !local variables
    logical :: ok
    ok=.false.
    iter=>en%family
    do while(associated(iter))
       ok= iter == family
       if (ok) exit
       iter => iter%family
    end do

  end function enum_get_from_char

  function enum_get_from_enum(en,family) result(iter)
    implicit none
    type(f_enumerator), intent(in) :: family

    type(f_enumerator), intent(in) :: en
    type(f_enumerator), pointer :: iter
    !local variables
    logical :: ok
    ok=.false.
    iter=>en%family
    do while(associated(iter))
       ok= iter == family
       if (ok) exit
       iter => iter%family
    end do

  end function enum_get_from_enum

  function enum_has_attribute(en,family) result(ok)
    implicit none
    type(f_enumerator), intent(in) :: family
    type(f_enumerator), intent(in) :: en
    logical :: ok

    ok =associated(en .getattr. family)
!!$    !local variables
!!$    type(f_enumerator), pointer :: iter
!!$
!!$    ok=.false.
!!$    iter=>en%family
!!$    do while(associated(iter) .and. .not. ok)
!!$       ok= iter == family
!!$       iter => iter%family
!!$    end do
  end function enum_has_attribute

  !> used in the assignment. Change the basic enumerator but combine hte attributes of the previous one
  !! with the attributes of the present one
  subroutine f_enum_update(dest,src)
    implicit none
    type(f_enumerator), intent(in) :: src
    type(f_enumerator), intent(inout) :: dest
    !local variables
    type(f_enumerator), pointer :: iter

    !start first by copying the attributes of the first enumerator
    iter=>src%family
    do while(associated(iter))
       call f_enum_attr(dest,iter)
       iter => iter%family
    end do
    !then scratch the root of the enumerator with src
    dest%name=src%name
    dest%id=src%id
  end subroutine f_enum_update

  function enum_has_char(en,family) result(ok)
    implicit none
    character(len=*), intent(in) :: family
    type(f_enumerator), intent(in) :: en
    logical :: ok

    ok =associated(en .getattr. family)
!!$    !local variables
!!$    type(f_enumerator), pointer :: iter
!!$
!!$    ok=.false.
!!$    iter=>en%family
!!$    do while(associated(iter) .and. .not. ok)
!!$       ok= iter == family
!!$       iter => iter%family
!!$    end do
  end function enum_has_char

  function enum_has_int(en,family) result(ok)
    implicit none
    integer, intent(in) :: family
    type(f_enumerator), intent(in) :: en
    logical :: ok

    ok =associated(en .getattr. family)

!!$    !local variables
!!$    type(f_enumerator), pointer :: iter
!!$
!!$    ok=.false.
!!$    iter=>en%family
!!$    do while(associated(iter) .and. .not. ok)
!!$       ok= iter == family
!!$       iter => iter%family
!!$    end do
  end function enum_has_int

  elemental pure function enum_is_enum(en,en1) result(ok)
    implicit none
    type(f_enumerator), intent(in) :: en
    type(f_enumerator), intent(in) :: en1
    logical :: ok
    ok = (en == en1%id) .and. (en == en1%name)
  end function enum_is_enum

  elemental pure function enum_is_int(en,int) result(ok)
    implicit none
    type(f_enumerator), intent(in) :: en
    integer, intent(in) :: int
    logical :: ok
    ok = en%id == int
  end function enum_is_int

  elemental pure function int_is_enum(int,en) result(ok)
    implicit none
    type(f_enumerator), intent(in) :: en
    integer, intent(in) :: int
    logical :: ok
    ok = en%id == int
  end function int_is_enum

  elemental pure function enum_is_char(en,char) result(ok)
    use yaml_strings, only: operator(.eqv.)
    implicit none
    type(f_enumerator), intent(in) :: en
    character(len=*), intent(in) :: char
    logical :: ok
    ok = trim(en%name) .eqv. trim(char)
  end function enum_is_char

  elemental pure function enum_is_not_enum(en,en1) result(ok)
    implicit none
    type(f_enumerator), intent(in) :: en
    type(f_enumerator), intent(in) :: en1
    logical :: ok
    ok = .not. (en == en1)
  end function enum_is_not_enum

  elemental pure function enum_is_not_int(en,int) result(ok)
    implicit none
    type(f_enumerator), intent(in) :: en
    integer, intent(in) :: int
    logical :: ok
    !ok = .not. (en == int)
    ok = .not. enum_is_int(en,int)
  end function enum_is_not_int

  elemental pure function enum_is_not_char(en,char) result(ok)
    implicit none
    type(f_enumerator), intent(in) :: en
    character(len=*), intent(in) :: char
    logical :: ok
    ok = .not. (en == char)
  end function enum_is_not_char

  !>integer of f_enumerator type.
  elemental pure function int_enum(en)
    type(f_enumerator), intent(in) :: en
    integer :: int_enum
    int_enum=en%id
  end function int_enum

  !>char of f_enumerator type.
  elemental pure function char_enum(en)
    type(f_enumerator), intent(in) :: en
    character(len=len(en%name)) :: char_enum
    char_enum=en%name
  end function char_enum

end module f_enums

max_stars_repo_name: adegomme/aiida-bigdft-plugin


text:
! { dg-do compile }
! PR 18568
! Find pointer-to-array components
module ints
   type :: bar
      integer, pointer :: th(:)
   end type bar
contains
   function foo(b)
      type(bar), intent(in) :: b
      integer :: foo(size(b%th))
      foo = 0
   end function foo
end module ints

program size_test
  use ints
end program size_test

! { dg-final { cleanup-modules "ints" } }

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
module mod1
#include "not_found.inc"
end module mod1

max_stars_repo_name: clementval/claw-compiler

max_issues_repo_name: skosukhin/claw-compiler

max_forks_repo_name: skosukhin/claw-compiler


! { dg-do compile }
! PR fortran/50627
module kernels
      select type (args) ! { dg-error "Unexpected SELECT TYPE" }
end module kernels


program main
    use SimulatorClass
    implicit none
    type(MPI_)              :: MPIData
    type(Field_),target     :: world
    integer                 :: TotalStep=40
    real(8)                 :: time=1.0d0

    call MPIData%Start()

    call world%Import()
    call Simulator(world,OptionalStep=TotalStep,OptionalTime=time)
    call world%Export()

    call MPIData%End()

end program


text:
        program main
        include 'mpif.h'

        integer NUM_DIMS
        parameter (NUM_DIMS=2)

        integer ierr
        integer errors, toterrors
        integer comm_temp, comm_cart, new_comm
        integer size, rank, i
        logical periods(NUM_DIMS)
        integer dims(NUM_DIMS)
        integer coords(NUM_DIMS)
        integer new_coords(NUM_DIMS)
        logical remain_dims(NUM_DIMS)
        integer newnewrank
        logical reorder
        integer topo_status
        integer ndims
        integer new_rank

        integer source, dest

        errors=0
        call MPI_INIT (ierr)

        call MPI_COMM_RANK( MPI_COMM_WORLD, rank, ierr)
        call MPI_COMM_SIZE (MPI_COMM_WORLD, size, ierr )

c
c    Clear dims array and get dims for topology
c
        do 100 i=1,NUM_DIMS
                dims(i)=0
                periods(i)= .false.
100     continue
        call MPI_DIMS_CREATE( size, NUM_DIMS, dims, ierr)

c
c     Make a new communicator with a topology
c
        reorder = .true.
        call MPI_CART_CREATE( MPI_COMM_WORLD, 2, dims, periods,
     $          reorder, comm_temp, ierr)
        call MPI_COMM_DUP (comm_temp, comm_cart, ierr)

c
c     Determine the status of the new communicator
c
        call MPI_TOPO_TEST (comm_cart, topo_status, ierr)
        IF (topo_status .ne. MPI_CART) then
           print *, "Topo_status is not MPI_CART"
           errors=errors+1
        ENDIF

c
c     How many dims do we have?
c
        call MPI_CARTDIM_GET( comm_cart, ndims, ierr)
        if (ndims .ne. NUM_DIMS ) then
           print *, "ndims (", ndims, ") is not NUM_DIMS (", NUMDIMS,
     $          ")"
           errors = errors+1
        ENDIF

c
c     Get the topology, does it agree with what we put in?
c
        do 500 i=1,NUM_DIMS
                dims(i)=0
                periods(i)=.false.
500     continue
        call MPI_CART_GET( comm_cart, NUM_DIMS, dims, periods, coords,
     $       ierr)
c
c     Does the mapping from coords to rank work?
c
        call MPI_CART_RANK( comm_cart, coords, new_rank, ierr)
        if (new_rank .ne. rank ) then
           print *, "New_rank = ", new_rank, " is not rank (", rank, ")"
           errors=errors+1
        endif

c
c     Does the mapping from rank to coords work
c
        call MPI_CART_COORDS( comm_cart, rank, NUM_DIMS, new_coords ,
     $       ierr)
        do 600 i=1,NUM_DIMS
                if (coords(i) .ne. new_coords(i)) then
                   print *, "coords(",i,") = ", coords(i), " not = ",
     $                  new_coords(i)
                   errors=errors + 1
                endif
600     continue

c
c     Let's shift in each dimension and see how it works!
c     Because it's late and I'm tired, I'm not making this
c     automatically test itself.
c
        do 700 i=1,NUM_DIMS
           call MPI_CART_SHIFT( comm_cart, (i-1), 1, source, dest, ierr)
c           print *, '[', rank, '] shifting 1 in the ', (i-1),
c     $                 ' dimension'
c           print *, '[', rank, ']     source = ', source,
c     $                 ' dest = ', dest

700     continue

c
c     Subdivide
c
        remain_dims(1)=.false.
        do 800 i=2,NUM_DIMS
                remain_dims(i)=.true.
800     continue
        call MPI_CART_SUB( comm_cart, remain_dims, new_comm, ierr)

c
c     Determine the status of the new communicator
c
        call MPI_TOPO_TEST( new_comm, topo_status, ierr )
        if (topo_status .ne. MPI_CART ) then
           print *, "Topo_status of new comm is not MPI_CART"
           errors=errors+1
        endif

c
c     How many dims do we have?
c
        call MPI_CARTDIM_GET( new_comm, ndims, ierr)
        if (ndims .ne. NUM_DIMS-1 ) then
           print *, "ndims (", ndims, ") is not NUM_DIMS-1"
           errors = errors+1
        endif

c
c     Get the topology, does it agree with what we put in?
c
        do 900 i=1,NUM_DIMS-1
                dims(i)=0
                periods(i)=.false.
900     continue
        call MPI_CART_GET( new_comm, ndims, dims, periods, coords, ierr)

c
c     Does the mapping from coords to rank work?
c
        call MPI_COMM_RANK( new_comm, newnewrank, ierr)
        call MPI_CART_RANK( new_comm, coords, new_rank, ierr)
        if (new_rank .ne. newnewrank ) then
           print *, "New rank (", new_rank, ") is not newnewrank"
           errors=errors+1
        endif

c
c     Does the mapping from rank to coords work
c
        call MPI_CART_COORDS( new_comm, new_rank, NUM_DIMS-1, new_coords
     $       ,  ierr)
        do 1000 i=1,NUM_DIMS-1
                if (coords(i) .ne. new_coords(i)) then
                   print *, "coords(",i,") = ", coords(i),
     $                  " != new_coords (", new_coords(i), ")"
                   errors=errors+1
                endif
1000    continue

c
c     We're at the end
c
        call MPI_COMM_FREE( new_comm, ierr)
        call MPI_COMM_FREE( comm_temp, ierr)
        call MPI_COMM_FREE( comm_cart, ierr)

c       call Test_Waitforall_( )

        call MPI_ALLREDUCE( errors, toterrors, 1, MPI_INTEGER,
     1                      MPI_SUM, MPI_COMM_WORLD, ierr )
        if (rank .eq. 0) then
           if (toterrors .eq. 0) then
              print *, ' No Errors'
           else
              print *, ' Done with ', toterrors, ' ERRORS!'
           endif
        endif
        call MPI_FINALIZE(ierr)
c          print *, '[', rank, '] done with ', errors, ' ERRORS!'

        end

max_stars_repo_name: scottkwarren/config-db

max_issues_repo_name: scottkwarren/config-db

max_forks_repo_name: scottkwarren/config-db


text:
!##############################################################################
!# ****************************************************************************
!# <name> x </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains
!# </purpose>
!##############################################################################

module x

  use fsystem

  implicit none

!<types>

  !<typeblock>

  type x
    !...
  end type

  !</typeblock>

!</types>

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

!<constants>

  !<constantblock description="x">

  ! logical value 'true'
  integer, parameter :: YES = 0

  !</constantblock>

!</constants>

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

end module

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
Jonathan Soo Hoo was a candidate for ASUCD ASUCD Senate Senate during the Winter 2012 ASUCD Election running as an independent. While he was a candidate, he did absolutely no campaigning, and did not win. The morning of election results, he released the following statement,

    Thanks everyone who supported me! We made the establishment worry this election by going line by line through their budget exposing their wasteful spending. I appreciate your support, & God bless you.
    Well see about election results later, but, at the end of the day, we are all winners because we can always take lessons learnt from this campaign with us. I just cannot thank enough all those other candidates who ran as well, and I wish them the best, even those who went out of their way to criticize me.
    Thank you & God Bless.

He is known for being a leader of Conservative causes around the UC Davis campus and across California.

ASUCD Election

Platform

Hello!

My name is Jonathan Soo Hoo, I am a political science & history major and a candidate serve you as a senator in the ASUCD Senate.  People have asked me, “Why are you running for the ASUCD Senator?” I tell them, “I do not see myself as running, I see myself as walking – walking in God’s Kingdom, trying to walk in the path which God has paved for me”.

Platform Initiatives:
1. Prudence
2. Fiscal Responsibility
3. What I learned from Chess

I have never served in the ASUCD, and I never thought I would serve in the ASUCD Senate.   However, I have seen the failures of the ASUCD to react properly with respect to the Occupy Wall Street Protesters on Campus, and, after much prayer, I have decided its my calling to run for ASUCD Senate, to shake up the establishment, including dedication to prudence.  I am a ready to serve you as a Senator in the ASUCD.

I would appreciate your vote, a vote for an individual who has the proven experience, and the leadership to take a wreckingball to the establishment.

Best Regards,
Jonathan Soo Hoo
Prudence:

Perhaps the gravest and most frustrating individual thing, for me, after the events on November 18, the ASUCD resolution talked of “military grade” pepper spray, of which does not exist, demonstrating a lack of research. Furthermore, the ASUCD Senate did not do a prudent job researching the events, inasmuch as, they hastily jumped to conclusions without talking to officers at the events.  I have done that, and as a senator, I will ensure prudence when dealing with a tough decision – I will gather all of the information from both sides of the conflict, and make a common sense conclusion based on that.

Fiscal Responsibility:

The ASUCD Senate deals with a multimillion dollar budget each year. Every year, it spends its budget, yet we still have random incidents where the Coho ceiling begins leaking during the winters. Why? There has been a flagrant dereliction of duty in terms of the allocation of funds.  We should only provide funds for things necessary, and not upgrade everything under the sun every year. We need to understand fiscal responsibility, and if the ASUCD senate has extra money, it’s the student’s money, and we should not shy away from giving it back to the UC Davis students.

How Chess imitates Life:

In chess you learn the importance of calculating moves in advance, and understanding cause and effect relationships.  I am a nationally recognized expert in Chess, and from Chess, I have learned many things about preparation, logical thinking, and the need to understand every side of every argument.  That kind of objectivism helps cure problems of groupthink.

Where I stand:

Occupy UC Davis/Wall Street

My message to those Occupy Davis folk is short & simple: Protesting on the quad if fine, but encamping on the quad is not.  In short, Get off our Quad.

I am a reasonable person, and if you want to protest, that is your right, BUT it is not your right to occupy the quad. And to the police officers, my message is simple: I appreciate what you do, and please, enforce the law.

20120207 22:06:15 nbsp Anyone who tries to use their religion to boost their political platform has A LOT to learn about leading people.

People have asked me, “Why are you running for the ASUCD Senator?” I tell them, “I do not see myself as running, I see myself as walking – walking in God’s Kingdom, trying to walk in the path which God has paved for me”.  KEEP THAT TO YOURSELF. Stop shoving your religion down everyones throat. How does this have anthing to do with what you think you are going to do for UCD? It doesnt... you are just trying to score brownie points with Christians and ostracize people of other religions. YOU ARE NOT GETTING MY VOTE, AND MANY PEOPLE I HAVE TALK TO AGREE.
 Users/AnitaLee

20120207 23:54:44 nbsp I am glad you brought this criticism up:

Firstly, let me state this very clearly, I believe in God, I am a proud believer in Jesus, and I am not going to apologize for my faith.

Second, it has everything to do with why I am running: I am not an individual who came to UC Davis, said Oh I want to be in the ASUCD Senate and has geared myself to running by serving in the ASUCD every which way I could. Perhaps, that is the problem we have now: too many individuals run for senate, and get elected by gearing themselves for the position, but in the process become all to accustomed with the way business is handled in the ASUCD Senate, and allow for a sort of group think.  I am an outsider, who is not afraid to step on some toes, and support take my experience leading outside of ASUCD and bring it to the Senate.  I am especially ready to step on the toes of the Occupy UC Davis folk who have a flagrant disregard for the law.  If you do not like that, I am not your candidate, and please do not vote for me.

Thirdly, please stop misrepresenting me with the strawman logical fallacy argument.

Finally, did I mention God or my faith in my platform initiatives? No. I did not.

And to fellow UC Davis students: Look this is what we are up against.  Individuals who will write scathing comments because an individual because they are proud of their faith. I am focused on the issues: I am representing the majority of UC Davis Students who want the Occupy Davis off our quad, yet are too afraid to voice their frustrations.  I am unapologetic, and I am willing to step on some toes to make it happen. We need to restore prudence to the ASUCD Senate, and I will ensure we focus on gathering the facts before making senate resolutions condemning the polices actions. Users/JonathanSooHoo

20120208 08:55:27 nbsp So you want to support and represent the students of UC Davis even though you hate half of them (liberals, protesters and gay people I am assuming because you were a supporter of the antigay platform of Rick Perry). See, What we are up against? Wow...attacking the voters... that is really going to get you a lot of votes, buddy..... NOT! You being so proud of being an unapologetic toe stepper is not going to get you any votes either. Just some advice, people do not want a total jerk representing them. I dont even know you, but from your ridiculous campaign information above and even worse, your above comment, I can see why you are a total outside. :) You must be doing this for fun because there can not be any way you can actually think you have a chance at winning. Your going to take the wisdom you learned from chess????LOL. Chess is not the real world... its a game!!!!!!!!  Users/mathewAcre

20120208 09:28:27 nbsp Jonathan,

First, with what power will you be able to kick out the Occupy movement protesters? I agree that being a ASUCD Senator is a high ranking position and the Occupy protesters must leave, but you will have no control over their right to protest, regardless of how many toes you step on. Please stop blowing smoke up our asses.

Second, its great that you are a proud believer in Jesus Christ! I too share that same belief, but to announce a statement like, I see myself walking walking in Gods Kingdom is clearly a sign to win the Christian vote.  I love my religion, and I love my politics, but I make sure to keep them far apart. If you were not trying to win over the Christian vote, then why did you bring up God in a political advertisement? Dont pull the straw man fallacy card, when you clearly had another incentive.

Third,when you publicize on social networking sites, expect to get some bad feed back. Dont bash the people who will be voting(but probably not) you into office. Frantically attacking individuals shows bad leadership skills, be more like Ronald Reagan, a true leader, and less like Rush Limbaugh, a whinny entertainer. Users/AndrewBusch

20120208 09:50:46 nbsp As a Christian, I am troubled by your campaign. God is bigger than any of your petty politics. I doubt Jesus would approve of you making him a part of your campaign. Surely youve read http://www.biblegateway.com/passage/?searchMatthew%2021:12–17;&versionNIV Matthew 21:1217, no? Jesus doesnt take too kindly to people who use God for personal gain. Implying that youre Gods candidate qualifies. Also, http://www.biblegateway.com/passage/?searchMatthew%206&versionNIV Matthew 6 has a lot to say about righteousness and making a show of it.

Furthermore, although ASUCD issues rarely intersect with issues of Christian morality, youve chosen a rare issue that does. And youre on the wrong side of it. Jesus called us to love everyone. He condemned violence. He would not support the violence Occupy UC Davis has received at the hands of the UC Davis Police Department. And the protestors were http://www.biblegateway.com/passage/?searchmatt%205:39&versionNIV Christlike in their response to the violence inflicted upon them by people sworn to protect them. Users/WilliamLewis

20120208 17:55:34 nbsp WHAT!? I am what the UC Davis students are up against??!! Why because I respect other peoples religions? I too am a christian, but I wear it in my heart and not on my sleeve. You say I write scathing comments because you are proud of your religion. I would encourage any and everyone to be proud of their religion. But there is a time and place. You obviously are too pompous, immature and selfrituous too realize that.

Also, I am not trying to misrepresent you, like you accused me... I am going off of the campaign platform you yourself wrote to represent yourself. Maybe take the critique and try to grow from it instead of making a ridiculous claim that I am what the UCD students are up against.

Geez...If you cant take the heat then stay out of the kitchen (and the kitchen is politics). You have totally showcased your lack of leadership in the way you responded to my comment, which you called scathing but was really just an honest reflection. A person running for an office of any kind should respect and appreciate peoples feedback, regardless of if it is complementary or not. You attacking me just shows what lack of understanding you have for others.

Finally, how dare you be so presumptuous to say that you represent the majority. We are all individuals and for you to be so off base to make the claim that you speak for many, just further illustrates that you are the exact type of person we do not need in office.. You sure as hell do not represent me (and by the way... I am a Christian Republican). Users/AnitaLee

20120208 21:53:16 nbsp Before deciding to enter this contest I never thought I would run, never had ambitions to run, and really wanted nothing to do with student government.  I was happy in my niche supporting causes on a statewide and national level. But I personally feel as though there is a higher calling. I know some of the thing that I say, not everyone will agree with, and thats fine, but I am just trying my best to walk the path God have laid out for me. Thats why I am a candidate, and I think it important to understand why people decided to seek office. I understand this campaign will not make me the most popular person on campus but I can take it. To conclude: my faith is the catalyst for my campaign.

I do not want to let the reason for my candidacy distract from the issues at hand and the platforms of my campaign: Prudence, Fiscal Responsibility, and what I learned from my years as a competitive chess player.

You are right, I cannot really force the occupy davis folk off the campus, but as an ASUCD Senator, I would write legislation condemning the Occupy Davis movements flagrant disregard for the law. I would also be a voice for reason and fact gathering before jumping to conclusions when future such as the events on November 18 happen. Users/JonathanSooHoo

20120209 08:38:51 nbsp  FAIL! hAHAhahahahhhahahha!!!

 Sorry but a prerequisite for being senator means that you must be able to write a clear and cohesive English sentence.

 ...history major and a candidate serve you as a senator.

In chess you learn the importance of calculating moves in advance, and understanding cause and effect relationships. I am a nationally recognized expert in Chess, and from Chess, I have learned... You added 3 commas  into these two sentences when you no commas were needed at all and for some odd reason capitalized the word chess. Unless chess is your moms name it is a common noun and deserves no capitalization.

 Individuals who will write scathing comments because an individual because they are proud of their faith. HAHA.

 Ever hear of editing your shit before you post on something as important as your political page??? HAHA. This is SOOO going on a fail website.

Sorry but we need literate people in office who can actually create clear thoughts. This is 3rd grade writing and you still couldnt do it correctly. The writing center helps people like you, dude. I would quit trying to be senator so bad and instead try to meet the University Writing requirement. Haha. Newsflash: Senators kind of have to know how to write a proper sentence.  Users/MayDay23

20120209 08:56:26 nbsp Hi Jonathan.

I think its great you have faith in God (I personally dont care for it, but I wont hold that against you). However, I question the decision to tell everyone that my faith is the catalyst for my campaign. Because, as WilliamLewis has stated, I hope youve read Matthew 21:1217, Jesus doesnt take too kindly to using him as a tool for self gain. What ever happened to actually practicing what you preach? I realize that its tough to disassociate yourself from an important aspect of your life, but frankly, I dont care. If youre going to be running for public office, you better be damn sure youre speaking for your peers and not yourself.

Another point Id like to bring up is your leadership experience: how exactly does being the Director of Finances & Public Relations for the UC Davis Archery Club lead me to believe that you will be the ideal Senate candidate? Youre going to have to clarify. What were your duties as State Chairman for the California Students for Rick Santorum? For Ricky Perry? And what exactly did you do for the DCR? How does your experience help your peers? Under the assumption that you are a conservative leaning student, how closely do you identify with the political candidates on a national level?

Chess is great game, it certainly encourages players to think ahead of the opponent, and thats a great mindset to have in politics. But again, back to the original question, how are you going to use your skills to help the student population? Do you have any initiatives you would like to see in place as soon as you are elected into a Senate position? Users/timchin

20120209 09:48:23 nbsp Why are all your ideas circulated around the pepperspray incident? It was like 4 months ago... get over it! Everyone else has including the occupiers. Let it go. Aside from that, there are so many logical fallacies in your writing it is ridiculous. Military grade pepper spray is just the street name for the high weapons grade agent which is more potent than normal mace that you can buy at a store. How do I know this???My dad owned a tactical gear and rifle shop for over 20 years. Military grade pepper spray absolutely does exist, it just is not classified under the layman’s term “military grade”. Looks like you showcased your own lack of researching.

And quite honestly, the response you made to the first comment made you look like a complete baby. Grow a pair. The criticism wasn’t even that bad and you chose an ad hominem rebuttal.

And why the hell do you keep saying “I never thought I would be running.” That is irrelevant and says nothing. Who cares? What does it matter? Being ASUCD senator is nothing something someone dreams of their whole life. Most of the other candidates never thought they would run; it was just an opportunity that dropped on their lap.

Finally, as a word of advice, I wouldn’t be so proud of the fact you supported someone whose campaign was a total crash and burn and who dropped out because of it (i.e. Rick Perry).
 Users/HLJ87

20120209 14:20:37 nbsp Do you have a name for the hand gesture youre doing in the facebook cover photo? I like it. Users/MikeyCrews

20120209 16:21:03 nbsp Hey God....
  I know you are super busy leading Jonathans campaign and everything, but do you think you could take a few minutes to help some of the starving children in Africa? Thanks Users/ObieBoy

20120209 16:29:28 nbsp I bet this is how he feels right now:  http://imgur.com/5MZQ5 Users/jdmz

20120209 16:31:34 nbsp Hey Jonathan, you say youre walking with God but it looks like God Is walking the other direction on your campaign.  Users/jdmz

20120210 00:15:31 nbsp Jonathan,

Lets face it well probably both be sharing the honor of holding the Most Hated Person on Campus title  nothing wrong with that at all. I think you have legitimate concerns for the campus you walk on but heres my advice for you  dont run against things, be FOR something.  Wrecking ball to the establishment politics was something I practiced for years in ASUCD, I had a little fun with it but ultimately it got to a point where I had a difficult time actually getting things done. There is room for conservative leadership in ASUCD, fiscal conservatism because the students dont want to see their money wasted. I hope you take the time to research the ASUCD budget and come up with some examples of spending youd like to see stopped.  You, will probably never be satisfied with your student government, but theres a fiscal conservative haven for you amongst the Business and Finance Commission, should you be unsuccessful but still want to be involved I suggest you apply to be on the commission.

Good luck. Users/GregWebb

20120210 12:15:58 nbsp Jonathan,
    To be perfectly honest with you, I do feel bad for some of the comments you have received; they are personal put downs and attack aspects of your being…but to be even more honest, the only person that can be blamed for that is yourself. I do not think you realize what a political platform is supposed to be. It seems like this whole page is an attack of those who do not share your conservative beliefs which is then wrapped in your religious beliefs which you time and time again make the focal point of your campaign.  I am alarmed that someone who studies political science would make the grandiose mistake of combining their religious beliefs with their political beliefs. The separation of church and state does not just apply to the government; it applies to any person in the political arena. Also, you used such phrases as “I want to shake up the establishment” and “take a wreckingball to the establishment”, which directly contradicts your position as a conservative senator who will use prudence in decision making. Also, these are terms you coopted from the same group you used this platform to bash (liberals and occupiers). You attack them for the same thing you say you will go and do, only in a conservative manner. Also, your whole platform is revolved around the pepper spray incident, which has come and gone and is not the defining essence of our University. You inserted only moral judgments and  contradict yourself many times. Then, you make the completely far off assertation that being a good chess player will somehow make you a good senator. If you cannot see how this is absolutely unrelated, then I truly am worried for you as a political science major. Making the claim that being good at chess will make you a good politician is parallel to me making the claim that I should go start my own business because I beat all my family at monopoly. Also, you should be telling about how you want to make things better for everyone, not just attacking one group of people. It becomes incredibly obvious that you have something personal against the occupiers, which is totally fine, but you cannot and should not bring that into your political campaign. Actually, it seems that the content of your campaign revolves only around your hate for this group. They are students of this community and whether you like them or not you will still have to be leading them and must answer to them if you intent on being elected. Finally, your pledge of dedication to Jesus Christ is somewhat problematic when you use it to support violence on our campus. This is a bit hypocritical, is it not? You support the word of Jesus yet you are behind law enforcement in inflicting pain onto others. Remember that Jesus was also a rebel of the state, he also wanted to explode the system, he also was a long haired hippy who probably didn’t shower very often, who preached love and said that it is easier for a camel to get into the eye of a needle than a rich man get into heaven. Would Jesus approve of anyone anywhere being physically harmed, regardless of what the reason was. No, he would not. So that is why so many people have voiced (both in the comments section of this page and in the streets) that you seem like a complete hypocrite who is only using your religion to gain votes. You are absolutely free to disagree with the protestors as many of us do, but to insert yourself as a Chrsitian would mean you would have to practice what you preach. For example, say “I do not personally believe in the political beliefs of the group, but I am wholly against anyone on campus or anywhere in the world, for that matter, being physically harmed because that goes against the word of Jesus.” Also, the way you responded to the first negative comment you got further exemplified that you are indeed a hypocrite. A true politician takes insults as motivation. You should have said… “I am sorry that we do not share similar political views, but I greatly appreciate you taking the time to comment, as well as voice your opinion. I am happy to hear your feedback and am open to any criticism that could help me grow as a person. Thank you for bringing it up, and I hope that if I am elected to serve, I can show you how much good I will do for UC Davis.” Instead of being a true Christian, you attacked the person.  Lastly, I want to address my final complaint (and please do not take this as an attack on your intelligence. I am writing this so that you can learn from all these mistakes, which you will need to do if you really want to have a career in government.) Jonathan, this platform is horribly written. It appears that you have absolutely no in depth knowledge of English and your syntax, grammar and punctuation are absolutely embarrassing. Did you put no effort into this at all? It comes off as if you do not even really care. Along with this, the pixilated photo of you with a scowl on your face making an odd hand gesture poorly pasted over the American flag is just laughable. Once again, please take these criticisms and grow from them. Do not let  them tear you down but instead build you up.
 Users/PatriciaH.

20120211 01:03:18 nbsp ^snaps Users/jdmz

20120211 01:45:46 nbsp ^snaps Users/jdmz

20120211 02:04:52 nbsp I like your shirt bro, keep things going. Users/Dozer

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


! Fortran program to find the root of equation using bisection

program bisection
	implicit none;

	integer iterations /0/;
	Real F, x, a, b, c, eps /.00001/; ! tolerance;
	F(x) = (x**3 - x - 2); ! statement function

	x = 0;
	do while((F(x) * F(x + 1)) .ge. 0)
		x = x + 1;
	end do

	if(F(x) .lt. 0) then
		a = x;
		b = x + 1;
	else
		a = x + 1;
		b = x;
	end if;

	iterations = iterations + 1;
	do while((abs(a - b)) > eps)
		c = (a + b ) / 2;

		if(F(c) .le. 0) then
			a = c;
		else
			b = c;
		end if;
	end do

	print *, "Iterations : ", iterations;
	print *, "Value of c : ", c;
	print *,"Root : ", F(c);
end program bisection