text:
*=======================================================================
*
* WCSLIB 4.24 - an implementation of the FITS WCS standard.
* Copyright (C) 1995-2014, Mark Calabretta
*
* This file is part of WCSLIB.
*
* WCSLIB is free software: you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* WCSLIB is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with WCSLIB.  If not, see http://www.gnu.org/licenses.
*
* Direct correspondence concerning WCSLIB to mark@calabretta.id.au
*
* Author: Mark Calabretta, Australia Telescope National Facility, CSIRO.
* http://www.atnf.csiro.au/people/Mark.Calabretta
* $Id: tlin.f,v 4.24 2014/09/18 15:25:02 mcalabre Exp $
*=======================================================================

      PROGRAM TLIN
*-----------------------------------------------------------------------
*
* TLIN tests the linear transformation routines supplied with WCSLIB.
*
*-----------------------------------------------------------------------
      DOUBLE PRECISION TOL
      PARAMETER (TOL = 1D-13)

      INTEGER   NAXIS, NCOORD, NELEM
      PARAMETER (NAXIS = 5, NCOORD = 2, NELEM  = 9)

      INTEGER   I, J, K, NFAIL, STATUS
      DOUBLE PRECISION CDELT(NAXIS), CRPIX(NAXIS), IMG(NELEM,2),
     :          PC(NAXIS,NAXIS), PIX0(NELEM,2), PIX(NELEM,2), RESID,
     :          RESIDMAX

*     On some systems, such as Sun Sparc, the struct MUST be aligned
*     on a double precision boundary, done here using an equivalence.
*     Failure to do this may result in mysterious "bus errors".
      INCLUDE 'lin.inc'
      INTEGER   LIN(LINLEN)
      DOUBLE PRECISION DUMMY
      EQUIVALENCE (LIN,DUMMY)

      DATA (CRPIX(I), I=1,NAXIS)
     :           /256D0, 256D0,  64D0, 128D0,   1D0/
      DATA ((PC(I,J),J=1,NAXIS),I=1,NAXIS)
     :           /  1.0D0,   0.5D0,   0D0,   0D0,   0D0,
     :              0.5D0,   1.0D0,   0D0,   0D0,   0D0,
     :              0.0D0,   0.0D0,   1D0,   0D0,   0D0,
     :              0.0D0,   0.0D0,   0D0,   1D0,   0D0,
     :              0.0D0,   0.0D0,   0D0,   0D0,   1D0/
      DATA (CDELT(I), I=1,NAXIS)
     :           /  1.2D0,   2.3D0,   3.4D0,   4.5D0,   5.6D0/
      DATA ((PIX0(I,J), I=1,NAXIS), J=1,2)
     :           /303.0D0, 265.0D0, 112.4D0, 144.5D0,  28.2D0,
     :             19.0D0,  57.0D0,   2.0D0,  15.0D0,  42.0D0/
*-----------------------------------------------------------------------
      WRITE (*, 10)
 10   FORMAT (
     :  'Testing WCSLIB linear transformation routines (tlin.f)',/,
     :  '------------------------------------------------------')

      STATUS = LINPUT (LIN, LIN_FLAG, -1, 0, 0)
      STATUS = LININI (NAXIS, LIN)

      DO 30 I = 1, NAXIS
        STATUS = LINPUT (LIN, LIN_CRPIX, CRPIX(I), I, 0)

        DO 20 J = 1, NAXIS
          STATUS = LINPUT (LIN, LIN_PC, PC(I,J), I, J)
 20     CONTINUE

        STATUS = LINPUT (LIN, LIN_CDELT, CDELT(I), I, 0)
 30   CONTINUE

      WRITE (*, *)
      DO 50 K = 1, NCOORD
        WRITE (*, 40) K, (PIX0(J,K), J=1,NAXIS)
 40     FORMAT ('PIX',I2,':',10F14.8)
 50   CONTINUE

      STATUS = LINP2X (LIN, NCOORD, NELEM, PIX0, IMG)
      IF (STATUS.NE.0) THEN
        WRITE (*, 60) STATUS
 60     FORMAT ('LINP2X ERROR',I3)
        GO TO 999
      END IF

      WRITE (*, *)
      DO 80 K = 1, NCOORD
        WRITE (*, 70) K, (IMG(J,K), J=1,NAXIS)
 70     FORMAT ('IMG',I2,':',10F14.8)
 80   CONTINUE

      STATUS = LINX2P (LIN, NCOORD, NELEM, IMG, PIX)
      IF (STATUS.NE.0) THEN
        WRITE (*, 90) STATUS
 90     FORMAT ('LINX2P ERROR',I3)
        GO TO 999
      END IF

      WRITE (*, *)
      DO 100 K = 1, NCOORD
        WRITE (*, 40) K, (PIX(J,K), J=1,NAXIS)
 100  CONTINUE

*     Check closure.
      NFAIL = 0
      RESIDMAX = 0D0

      DO 120 K = 1, NCOORD
        DO 110 J = 1, NAXIS
          RESID = ABS(PIX(j,k) - PIX0(j,k))
          IF (RESIDMAX.LT.RESID) RESIDMAX = RESID
          IF (RESID.GT.TOL) NFAIL = NFAIL + 1
 110    CONTINUE
 120  CONTINUE

      WRITE (*, 130) RESIDMAX
 130  FORMAT (/,'LINP2X/LINX2P: Maximum closure residual =',1PE8.1,
     :  ' pixel.')

      IF (NFAIL.NE.0) THEN
        WRITE (*, 140) NFAIL
 140    FORMAT (/,'FAIL:',I5,' closure residuals exceed reporting ',
     :    'tolerance.')
      ELSE
        WRITE (*, 150)
 150    FORMAT (/,'PASS: All closure residuals are within reporting ',
     :    'tolerance.')
      END IF

 999  STATUS = LINFREE(LIN)

      END

ext: f

max_stars_repo_name: kapteyn-astro/kapteyn

max_issues_repo_name: kernsuite-debian/kapteyn

max_forks_repo_name: kernsuite-debian/kapteyn


text:
C    Copyright(C) 1988-2017 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C $Id: selssn.f,v 1.2 1998/03/22 05:34:45 gdsjaar Exp $
C $Log: selssn.f,v $
C Revision 1.2  1998/03/22 05:34:45  gdsjaar
C General cleanp of unused variables. Reordered DATA statements in
C command.f so would compile with f2c.
C
C Revision 1.1.1.1  1991/02/21 15:45:33  gdsjaar
C NUMBERS: Greg Sjaardema, initial Unix release
C
c Revision 1.1  1991/02/21  15:45:32  gdsjaar
c Initial revision
c
C=======================================================================
      SUBROUTINE SELSSN (SELECT, NUMNP, NLIST, LIST,
     *   IDSS, NNSS, IPNSS, LTNSS, NUMSS, NUMSEL)
C=======================================================================
C    IDSS  (NUMSS) SIDE SET IDS
C    NNSS  (NUMSS) SIDE SET NODE    COUNTS
C    IPNSS (NUMSS) SIDE SET NODE    POINTERS
C    LTNSS (LSSNL) SIDE SET NODE    LIST
C
      LOGICAL SELECT(*)
      INTEGER LIST(*), IDSS(*), NNSS(*), IPNSS(*), LTNSS(*)
      CHARACTER*80 STRA

      CALL INILOG (NUMNP, .FALSE., SELECT)

      DO 20 II = 1, NLIST
         IFLG = LOCINT (LIST(II), NUMSS, IDSS)
         IF (IFLG .EQ. 0) THEN
            WRITE (STRA, 50) LIST(II)
            CALL SQZSTR (STRA, LSTR)
            CALL PRTERR ('ERROR', STRA(:LSTR))
         ELSE
            IBEG = IPNSS(IFLG)
            IEND = IBEG + NNSS(IFLG) - 1
            DO 10 I=IBEG, IEND
               SELECT(LTNSS(I)) = .TRUE.
   10       CONTINUE
         END IF
   20 CONTINUE

      NUMSEL = NUMEQL (.TRUE., NUMNP, SELECT)
      WRITE (STRA, 30) NUMSEL
      CALL SQZSTR(STRA, LSTR)
      WRITE (*, 40) STRA(:LSTR)
   30 FORMAT (I10,' nodes selected')
   40 FORMAT (/5X,A)

   50 FORMAT (' Set Flag ',I10,' not found. ')
      RETURN
      END

max_stars_repo_name: mathstuf/seacas

max_stars_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_issues_repo_name: mathstuf/seacas

max_issues_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_forks_repo_name: mathstuf/seacas

max_forks_repo_licenses: BSD-3-Clause NetCDF Zlib MIT


text:
mugadork can describe himself or herself here.

20100715 23:11:12 nbsp Hello and welcome to the Wiki! Im sorry nobody welcomed you before, it looks like you have been here a while! Users/hankim

20100716 01:48:58 nbsp Hmmmmmmm Users/StevenDaubert

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 02.01.03/tstcid                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE TSTCID (ORGID, RESID, ORGSTB, ORGRFB,
     1                   ORGPTB, RSSTB, RSRFB, RSPTB, ORGSTE,
     2                   ORGCHE, ORGPTE, RSSTE, RSCHE, RSPTE,
     3                   SRSTR, TCNUM, EXCSS)

C Input Parameters:
C INTEGER orgid           original structure identifier
C INTEGER resid           resulting structure identifier

C   The following 6 input parameters identify various structure
C   states before the change function is executed.
C INTEGER orgstb          original structure open state (NOPEN, NCLOS)
C INTEGER orgrfb          original structure referenced state (NREF, NNRF)
C INTEGER orgptb          original structure posted state (NPST, NNPT)
C INTEGER rsstb           resulting structure open state (NOPEN, NCLOS)
C INTEGER rsrfb           resulting structure referenced state (NREF, NNRF)
C INTEGER rsptb           resulting structure posted state (NPST, NNPT)

C   The following 6 input parameters identify various expected structure
C   states after the change function is executed.
C INTEGER orgste          original structure open state (NOPEN, NCLOS)
C INTEGER orgche          original structure contents (NEMP, NORG)
C INTEGER orgpte          original structure posted state (NPST, NNPT)
C INTEGER rsste           resulting structure open state (NOPEN, NCLOS)
C INTEGER rsche           resulting structure contents (NEMP, NORG)
C INTEGER rspte           resulting structure posted state (NPST, NNPT)

C CHARACTER srstr         identification of SR numbers
C CHARACTER tcnum         identification of test case number
C CHARACTER excss         representation of expected CSS state

C TSTCID is used to generate the test messages associated with
C <change structure identifer>.  The conditions
C stated are tested and pass/fail is returned.

      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

C Enumeration values for subroutine parameters:
C   structure state: non-existent   opened       closed
      INTEGER        NOEXE,         NOPEN,       NCLOS
      PARAMETER     (NOEXE = -1,    NOPEN = 0,   NCLOS = 1)

C   structure posted state:
C                    structure posted     structure not posted
      INTEGER         NPST,                NNPT
      PARAMETER      (NPST = 0,            NNPT = 1)

C   structure reference status:
C                    referenced  not referenced
      INTEGER        NREF,       NNRF
      PARAMETER     (NREF = 2,   NNRF = 3)

C   structure contents:
C                    empty     original
      INTEGER        NEMP,     NORG
      PARAMETER     (NEMP = 0, NORG = 1)

      INTEGER ORGID, RESID, ORGSTB, ORGRFB, ORGPTB, RSSTB,
     1        RSRFB, RSPTB, ORGSTE, ORGCHE, ORGPTE, RSSTE, RSCHE,
     2        RSPTE, INTP1, INTP2, INTP3, INTP4, SRPT, MSGSZ,
     3        CSSSZ, TCSZ, OPSTRA, PSTSTA

      INTEGER ITRIM

      CHARACTER STRG*300, SRSTR*(*), MSGBUF*900, INVMSG*29
      CHARACTER TCNUM*(*), EXCSS*(*)
      CHARACTER*200 STRST1, STRST2, STRST3, STRST4

      LOGICAL CSSEQ, CONTOK

      REAL    RDUM1

C check the input parameters to ensure they are in bounds

      INVMSG = ' has invalid value in TSTCID.'

      IF (ORGSTB .NE. NOEXE  .AND.
     1    ORGSTB .NE. NOPEN  .AND.
     2    ORGSTB .NE. NCLOS)    CALL UNMSG ('Orgstb' // INVMSG)

      IF (ORGRFB .NE. NOEXE .AND.
     1    ORGRFB .NE. NREF  .AND.
     2    ORGRFB .NE. NNRF)     CALL UNMSG ('Orgrfb' // INVMSG)

      IF (ORGPTB .NE. NOEXE .AND.
     1    ORGPTB .NE. NPST  .AND.
     2    ORGPTB .NE. NNPT)     CALL UNMSG ('Orgptb' // INVMSG)

      IF (RSSTB  .NE. NOEXE  .AND.
     1    RSSTB  .NE. NOPEN  .AND.
     2    RSSTB  .NE. NCLOS)    CALL UNMSG ('Rsstb' // INVMSG)

      IF (RSRFB  .NE. NOEXE  .AND.
     1    RSRFB  .NE. NREF   .AND.
     2    RSRFB  .NE. NNRF)     CALL UNMSG ('Rsrfb' // INVMSG)

      IF (RSPTB  .NE. NOEXE  .AND.
     1    RSPTB  .NE. NPST   .AND.
     2    RSPTB  .NE. NNPT)     CALL UNMSG ('Rsptb' // INVMSG)

      IF (ORGSTE .NE. NOEXE  .AND.
     1    ORGSTE .NE. NOPEN  .AND.
     2    ORGSTE .NE. NCLOS)    CALL UNMSG ('Orgste' // INVMSG)

      IF (ORGCHE .NE. NOEXE  .AND.
     1    ORGCHE .NE. NEMP)     CALL UNMSG ('Orgche' // INVMSG)

      IF (ORGPTE .NE. NOEXE  .AND.
     1    ORGPTE .NE. NPST   .AND.
     2    ORGPTE .NE. NNPT)     CALL UNMSG ('Orgpte' // INVMSG)

      IF (RSSTE  .NE. NOPEN  .AND.
     1    RSSTE  .NE. NCLOS)    CALL UNMSG ('Rsste' // INVMSG)

      IF (RSCHE  .NE. NEMP   .AND.
     1    RSCHE  .NE. NORG)     CALL UNMSG ('Rsche' // INVMSG)

      IF (RSPTE  .NE. NPST   .AND.
     1    RSPTE  .NE. NNPT)     CALL UNMSG ('Rspte' // INVMSG)

      CALL TCSCID (ORGSTB, ORGRFB, ORGPTB, STRST1, INTP1)
      CALL TCSCID (RSSTB,  RSRFB,  RSPTB,  STRST2, INTP2)
      CALL TCSCID (ORGSTE, ORGCHE, ORGPTE, STRST3, INTP3)
      CALL TCSCID (RSSTE,  RSCHE,  RSPTE,  STRST4, INTP4)

C Test condition number
      TCSZ = ITRIM (TCNUM)

C generating the string test condition used in setmsg
      MSGBUF = '<Change structure identifier> with the '             //
     1         'precondition being '                                 //
     2         '(original structure = ' // STRST1(1:INTP1)           //
     3         ' and the resulting structure = ' // STRST2(1:INTP2)  //
     4         ') should yield the expected results of (original '   //
     5         'structure = '//STRST3(1:INTP3)//' and resulting '    //
     6         'structure = '//STRST4(1:INTP4)                       //
     7         ') after execution of the function as stated by '     //
     8         'test condition '//TCNUM(1:TCSZ)//' of the '          //
     9         'truth table.'

      SRPT  = ITRIM (SRSTR)
      MSGSZ = ITRIM (MSGBUF)
      CALL SETMSG (SRSTR(1:SRPT), MSGBUF(1:MSGSZ))

C subroutine to set the initial state of the CSS
      CALL STDCSS

C when necessary, initialize the open, close status of the specific
C structure
      IF (ORGSTB .EQ. NOPEN) THEN
         IF (RSSTB  .EQ. NOPEN) THEN
            CALL UNMSG ('Bad pre-condition: both original and ' //
     1                  'resulting OPEN.')
         ELSE
            CALL POPST (ORGID)
         ENDIF
      ELSE
         IF (RSSTB  .EQ. NOPEN) THEN
            CALL POPST (RESID)
         ENDIF
      ENDIF

C when necessary intialize the posting status of the specific structure
      IF (ORGPTB .EQ. NPST) CALL PPOST (WKID, ORGID, 1.)
      IF (RSPTB  .EQ. NPST) CALL PPOST (WKID, RESID, 1.)

C Formulate a string indicating the element types and contents for
C the original structure, before execution of function
      CALL ELSTR (ORGID, STRG)

      CALL PCSTID (ORGID, RESID)

C comparison of the original expected state to the actual state
      CALL ACTST (ORGID, STRG, ORGCHE, OPSTRA, CONTOK, PSTSTA, RDUM1)
      IF (OPSTRA .EQ. ORGSTE      .AND.
     1    CONTOK                  .AND.
     2    PSTSTA .EQ. ORGPTE)        THEN
C OK so far - do nothing
      ELSE
          CALL FAIL
          CALL INMSG ('The actual original structure status is ' //
     1                'incorrect.')
          GOTO 750
      ENDIF

C comparison of the resulting expected state to the actual state
      CALL ACTST (RESID, STRG, RSCHE, OPSTRA, CONTOK, PSTSTA, RDUM1)
      IF (OPSTRA .EQ. RSSTE     .AND.
     1    CONTOK                .AND.
     2    PSTSTA .EQ. RSPTE)       THEN
          CALL PASS
      ELSE
          CALL FAIL
          CALL INMSG ('The actual resulting structure status is ' //
     1                'incorrect.')
      ENDIF

C generate a test condition string dealing with the state of the
C CSS.

 750  CONTINUE
      MSGBUF = '<Change structure identifier> with the '             //
     1         'precondition being '                                 //
     2         '(original structure = ' // STRST1(1:INTP1)           //
     3         ' and resulting structure = ' // STRST2(1:INTP2)      //
     4         ') should change the contents of the CSS in '         //
     5         'accordance with the substitution of the '            //
     6         'resulting identifier for the original '              //
     7         'identifier.'

      CSSSZ = ITRIM (MSGBUF)
      CALL SETMSG (SRSTR(1:SRPT), MSGBUF(1:CSSSZ))

      CALL IFPF (CSSEQ(EXCSS))

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 02.01.03/tcscid                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE TCSCID (OPSTRA, STRSTA, PSTSTA, STRST, INTP)

C     Input Parameters:
C     INTEGER opstra     open structure indicator (NOEXE, NOPEN, NCLOS)
C     INTEGER strsta     structure status indicator (NOEXE, NREF, NNRF,
C                                                    NEMP,  NORG )
C     INTEGER pststa     posted structure indicator (NOEXE, NPST, NNPT)

C     Output Parameters:
C     CHARACTER strst    string indicating a structure's state as
C                        determined by the input parameters
C     INTEGER intp       the actual length of the string

C Tcscid returns a string and its length indicating the state of a
C structure.  The structure can be: open or closed, referenced or not
C referenced, empty or with original contents, and posted or not posted.

      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

C Enumeration values for subroutine parameters:
C   structure state: non-existent   opened       closed
      INTEGER        NOEXE,         NOPEN,       NCLOS
      PARAMETER     (NOEXE = -1,    NOPEN = 0,   NCLOS = 1)

C   structure posted state:
C                    structure posted     structure not posted
      INTEGER         NPST,                NNPT
      PARAMETER      (NPST = 0,            NNPT = 1)

C   structure reference status:
C                    referenced  not referenced
      INTEGER        NREF,       NNRF
      PARAMETER     (NREF = 2,   NNRF = 3)

C   structure contents:
C                    empty     original
      INTEGER        NEMP,     NORG
      PARAMETER     (NEMP = 0, NORG = 1)

      INTEGER OPSTRA, PSTSTA, STRSTA, INTP, ITRIM

      CHARACTER STRST*(*)

      CHARACTER OPSTAB (NOPEN:NCLOS)*30, STRTAB (NEMP:NNRF)*30,
     1          PSTTAB (NPST:NNPT)*30
      DATA OPSTAB / 'OPEN,', 'CLOSED,' /

      DATA STRTAB / 'EMPTY,'          ,
     1              'ORIGINAL,'       ,
     2              'REFERENCED,'     ,
     3              'NOT-REFERENCED,' /

      DATA PSTTAB / 'and POSTED', 'and NOT-POSTED'  /

      IF (OPSTRA .EQ. NOEXE) THEN
          IF (PSTSTA .EQ. NOEXE   .AND.
     1        STRSTA .EQ. NOEXE)    THEN
             STRST = 'NON-EXISTENT'
             GOTO 250
          ELSE
             CALL UNMSG ('Problem with the structure state being '//
     1                   'non-existent in subroutine TCSCID.')
          ENDIF
      ENDIF

      STRST        = OPSTAB (OPSTRA)
      INTP  = ITRIM (STRST) + 2
      STRST(INTP:) = STRTAB (STRSTA)
      INTP  = ITRIM (STRST) + 2
      STRST(INTP:) = PSTTAB (PSTSTA)

 250  CONTINUE
      INTP = ITRIM (STRST)

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 02.01.03/tstcir                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE TSTCIR (TCNUM, ORGID, RESID, EXCSS,
     1                   ORGSTB,         ORGPTB, RSSTB,        RSPTB,
     2                   ORGSTE, ORGCHE, ORGPTE, RSSTE, RSCHE, RSPTE)

C Input Parameters:
C CHARACTER tcnum         identification of test case number
C INTEGER   orgid         original structure identifier
C INTEGER   resid         resulting structure identifier
C CHARACTER excss         representation of expected CSS state

C   The following 4 input parameters identify various structure
C   states before the change function is executed.
C INTEGER orgstb          original structure open state (NOPEN, NCLOS)
C INTEGER orgptb          original structure posted state (NPSTO, NNPT)
C INTEGER rsstb           resulting structure open state (NOPEN, NCLOS)
C INTEGER rsptb           resulting structure posted state (NPSTR, NNPT)

C   The following 6 input parameters identify various expected structure
C   states after the change function is executed.
C INTEGER orgste          original structure open state (NOPEN, NCLOS)
C INTEGER orgche          original structure contents (NEMP, NORG)
C INTEGER orgpte          original structure posted state (NPSTR, NPSTO, NNPT)
C INTEGER rsste           resulting structure open state (NOPEN, NCLOS)
C INTEGER rsche           resulting structure contents (NEMP, NORG)
C INTEGER rspte           resulting structure posted state (NPSTR, NPSTO, NNPT)

C TSTCIR is used to generate the test messages associated with
C <change structure identifier and references>.  The conditions
C stated are tested and pass/fail is returned.

      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

C Enumeration values for subroutine parameters:
C   structure state: non-existent   opened       closed
      INTEGER        NOEXE,         NOPEN,       NCLOS
      PARAMETER     (NOEXE = -1,    NOPEN = 0,   NCLOS = 1)

C   structure posted state:
C                                           posted        posted
C                    not posted   posted    priority=R,   priority=O
      INTEGER        NNPT,        NPST,     NPSTR,        NPSTO
      PARAMETER     (NNPT = 1,    NPST = 0, NPSTR = 4,    NPSTO = 5)

C   structure contents:
C                    empty     original
      INTEGER        NEMP,     NORG
      PARAMETER     (NEMP = 0, NORG = 1)

      INTEGER ORGID, RESID, ORGSTB, ORGPTB, RSSTB,
     1        RSPTB, ORGSTE, ORGCHE, ORGPTE, RSSTE, RSCHE,
     2        RSPTE, INTP1, INTP2, INTP3, INTP4, MSGSZ,
     3        CSSSZ, TCSZ, OPSTRA, PSTSTA

      INTEGER ITRIM

      CHARACTER STRG*300, MSGBUF*900, INVMSG*29
      CHARACTER TCNUM*(*), EXCSS*(*)

      LOGICAL CSSEQ, CONTOK

      CHARACTER*200 STRST1, STRST2, STRST3, STRST4

      REAL          ORGPRI, RESPRI, PSTPRI

C set priorities
      ORGPRI = 0.1
      RESPRI = 0.2

C check the input parameters to ensure they are in bounds

      INVMSG = ' has invalid value in TSTCIR.'

      IF (ORGSTB .NE. NOEXE  .AND.
     1    ORGSTB .NE. NOPEN  .AND.
     2    ORGSTB .NE. NCLOS)    CALL UNMSG ('Orgstb' // INVMSG)

      IF (ORGPTB .NE. NOEXE .AND.
     1    ORGPTB .NE. NPSTO .AND.
     2    ORGPTB .NE. NNPT)     CALL UNMSG ('Orgptb' // INVMSG)

      IF (RSSTB  .NE. NOEXE  .AND.
     1    RSSTB  .NE. NOPEN  .AND.
     2    RSSTB  .NE. NCLOS)    CALL UNMSG ('Rsstb' // INVMSG)

      IF (RSPTB  .NE. NOEXE  .AND.
     1    RSPTB  .NE. NPSTR  .AND.
     2    RSPTB  .NE. NNPT)     CALL UNMSG ('Rsptb' // INVMSG)

      IF (ORGSTE .NE. NOEXE  .AND.
     1    ORGSTE .NE. NOPEN)    CALL UNMSG ('Orgste' // INVMSG)

      IF (ORGCHE .NE. NOEXE  .AND.
     1    ORGCHE .NE. NEMP)     CALL UNMSG ('Orgche' // INVMSG)

      IF (ORGPTE .NE. NOEXE  .AND.
     1    ORGPTE .NE. NNPT)     CALL UNMSG ('Orgpte' // INVMSG)

      IF (RSSTE  .NE. NOPEN  .AND.
     1    RSSTE  .NE. NCLOS)    CALL UNMSG ('Rsste' // INVMSG)

      IF (RSCHE  .NE. NEMP   .AND.
     1    RSCHE  .NE. NORG)     CALL UNMSG ('Rsche' // INVMSG)

      IF (RSPTE  .NE. NPSTR  .AND.
     1    RSPTE  .NE. NPSTO  .AND.
     2    RSPTE  .NE. NNPT)     CALL UNMSG ('Rspte' // INVMSG)

      CALL TCSCIR (ORGSTB, NOEXE,  ORGPTB, STRST1, INTP1)
      CALL TCSCIR (RSSTB,  NOEXE,  RSPTB,  STRST2, INTP2)
      CALL TCSCIR (ORGSTE, ORGCHE, ORGPTE, STRST3, INTP3)
      CALL TCSCIR (RSSTE,  RSCHE,  RSPTE,  STRST4, INTP4)

C Test condition number
      TCSZ = ITRIM (TCNUM)

C generating the string test condition used in setmsg
      MSGBUF =  '<Change structure identifier and '                  //
     1          'references> with the precondition '                 //
     2          'being (original structure = '//STRST1(1:INTP1)      //
     3          ' and the resulting structure = '//STRST2(1:INTP2)   //
     4          ') should yield the expected results of (original '  //
     5          'structure = '//STRST3(1:INTP3)//' and resulting '   //
     6          'structure = '//STRST4(1:INTP4)                      //
     7          ') after execution of the function as stated by '    //
     8          'test condition '//TCNUM(1:TCSZ)//' of the '         //
     9          'truth table.'

      MSGSZ = ITRIM (MSGBUF)
      CALL SETMSG ('1', MSGBUF(1:MSGSZ))

C subroutine to set the initial state of the CSS
      CALL STDCSS

C when necessary, initialize the open, close status of the specific
C structure
      IF (ORGSTB .EQ. NOPEN) THEN
         IF (RSSTB  .EQ. NOPEN) THEN
            CALL UNMSG ('Bad pre-condition: both original and ' //
     1                  'resulting OPEN.')
         ELSE
            CALL POPST (ORGID)
         ENDIF
      ELSE
         IF (RSSTB  .EQ. NOPEN) THEN
            CALL POPST (RESID)
         ENDIF
      ENDIF

C when necessary intialize the posting status of the specific structure
      IF (ORGPTB .EQ. NPSTO) CALL PPOST (WKID, ORGID, ORGPRI)
      IF (RSPTB  .EQ. NPSTR) CALL PPOST (WKID, RESID, RESPRI)

C Formulate a string indicating the element types and contents for
C the original structure, before execution of function.
      CALL ELSTR (ORGID, STRG)

      CALL PCSTIR (ORGID, RESID)

C get actual original status
      CALL ACTST (ORGID, STRG, ORGCHE, OPSTRA, CONTOK, PSTSTA, PSTPRI)

C comparison of the original expected state to the actual state
      IF (OPSTRA .EQ. ORGSTE    .AND.
     1    CONTOK                .AND.
     2    PSTSTA .EQ. ORGPTE)  THEN
C OK so far - do nothing
      ELSE
C no need to check priority, since original should always be unposted
C or non-existent
           CALL FAIL
           CALL INMSG ('The original structure status is incorrect.')
           GOTO 750
      ENDIF

C get actual resulting status
      CALL ACTST (RESID, STRG, RSCHE, OPSTRA, CONTOK, PSTSTA, PSTPRI)

C comparison of the resulting expected state to the actual state
      IF (OPSTRA .EQ. RSSTE  .AND. CONTOK) THEN
C OK so far - do nothing
      ELSE
          CALL FAIL
          CALL INMSG ('The resulting structure open status or ' //
     1                'contents is incorrect.')
          GOTO 750
      ENDIF

      IF     (RSPTE  .EQ. NPSTR) THEN
         CALL IFPF (PSTSTA .EQ. NPST  .AND.  PSTPRI .EQ. RESPRI)
      ELSEIF (RSPTE  .EQ. NPSTO) THEN
         CALL IFPF (PSTSTA .EQ. NPST  .AND.  PSTPRI .EQ. ORGPRI)
      ELSEIF (RSPTE  .EQ. NNPT)  THEN
         CALL IFPF (PSTSTA .EQ. NNPT)
      ENDIF

C generate a test condition string dealing with the state of the CSS.

 750  CONTINUE
      MSGBUF =  '<Change structure identifier and '                  //
     1          'references> with the precondition being '           //
     2          '(original structure = ' // STRST1(1:INTP1)          //
     3          ' and resulting structure = ' // STRST2(1:INTP2)     //
     4          ') should change the contents of the CSS in '        //
     5          'accordance with the substitution of the '           //
     6          'resulting identifier for the original '             //
     7          'identifier.'

      CSSSZ = ITRIM (MSGBUF)
      CALL SETMSG ('1 7 8', MSGBUF(1:CSSSZ))

      CALL IFPF (CSSEQ(EXCSS))

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 02.01.03/tcscir                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE TCSCIR (OPSTRA, STRSTA, PSTSTA, STRST, INTP)

C     Input Parameters:
C     INTEGER opstra     open structure indicator (NOEXE, NOPEN, NCLOS)
C     INTEGER strsta     structure status indicator (NOEXE, NEMP,  NORG )
C     INTEGER pststa     posted structure indicator (NOEXE, NNPT, NPSTR, NPSTO)

C     Output Parameters:
C     CHARACTER strst    string indicating a structure's state as
C                        determined by the input parameters
C     INTEGER intp       the actual length of the string

C Tcscir returns a string and its length indicating the state of a
C structure.  The structure can be: open or closed, referenced or not
C referenced, empty or with original contents, and posted or not posted.

      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

C Enumeration values for subroutine parameters:
C   structure state: non-existent   opened       closed
      INTEGER        NOEXE,         NOPEN,       NCLOS
      PARAMETER     (NOEXE = -1,    NOPEN = 0,   NCLOS = 1)

C   structure posted state:
C                    not posted   posted:priority=R,   posted:priority=O
      INTEGER        NNPT,        NPSTR,               NPSTO
      PARAMETER     (NNPT = 1,    NPSTR = 4,           NPSTO = 5)

C   structure contents:
C                    empty     original
      INTEGER        NEMP,     NORG
      PARAMETER     (NEMP = 0, NORG = 1)

      INTEGER OPSTRA, PSTSTA, STRSTA, INTP, ITRIM

      CHARACTER STRST*(*)

      CHARACTER OPSTAB (NOPEN:NCLOS)*30, STRTAB (NOEXE:NORG)*30,
     1          PSTTAB (NNPT:NPSTO)*50
      DATA OPSTAB / 'OPEN', 'CLOSED' /

      DATA STRTAB / ' ', ', EMPTY,', ', ORIGINAL,' /

      DATA PSTTAB / 'and NOT-POSTED', ' ', ' ',
     1              'and POSTED with old resulting priority',
     2              'and POSTED with old original priority' /

      IF (OPSTRA .EQ. NOEXE) THEN
          IF (PSTSTA .EQ. NOEXE   .AND.
     1        STRSTA .EQ. NOEXE)    THEN
             STRST = 'NON-EXISTENT'
             GOTO 250
          ELSE
             CALL UNMSG ('Problem with the structure state being '//
     1                   'non-existent in subroutine TCSCIR.')
          ENDIF
      ENDIF

      STRST        = OPSTAB (OPSTRA)
      INTP  = ITRIM (STRST) + 1
      STRST(INTP:) = STRTAB (STRSTA)
      INTP  = ITRIM (STRST) + 2
      STRST(INTP:) = PSTTAB (PSTSTA)

 250  CONTINUE
      INTP = ITRIM (STRST)

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 02.01.03/elstr                          *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE ELSTR (STRID, STRG)

C     Input Parameter:
C     INTEGER strid              structure identifier

C     Output Parameter:
C     CHARACTER strg             string identifying element types
C                                and contents for strid

C  Elstr returns the character string STRG which contains integer-like
C  substrings separated by commas. The substrings of STRG represent an
C  ordered listing of label identifiers and execute structure identifiers
C  used to indicate the structure element positions of a particular
C  structure in the network.

C  e.g. The structure 110 creates STRG = "66, 111, 66, 120, 67, 901"
C             <open structure> 110
C             <execute structure> 111
C             <execute structure> 120
C             <label> 901
C             <close structure>

      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

C PHIGS enumeration parameter for PEEXST and PELB
      INTEGER    PEEXST,      PELB
      PARAMETER (PEEXST = 66, PELB = 67)

C structure status indicator   non-existent, empty,      non-empty
      INTEGER                  PSNOEX,       PSEMPT,     PSNEMP
      PARAMETER               (PSNOEX = 0,   PSEMPT = 1, PSNEMP = 2)

C array length parameter values
      INTEGER    LINT,      LRL,      LSTR
      PARAMETER (LINT = 50, LRL = 50, LSTR = 50)

      INTEGER   ELPOS, ELTYPE, INTG, INTLEN, RL, RLLEN, STLEN, STR,
     1          STRID, INTAR(LINT), STRL(LSTR), NXCHAR, IEXIST

      REAL      RLAR(LRL)

      CHARACTER STRG*(*), STRAR(LSTR)*80

C initialize values
      STRG    = ' '
      NXCHAR  = 1
      ELPOS   = 1

C check the status of the structure
      CALL PQSTST (STRID, ERRIND, IEXIST)
      CALL CHKINQ ('pqstst', ERRIND)
      IF (IEXIST .EQ. PSNOEX  .OR.
     1    IEXIST .EQ. PSEMPT)    RETURN

C create the string STRG for the network structure STRID
900   CONTINUE
      CALL PQETS (STRID, ELPOS, ERRIND, ELTYPE, INTLEN, RLLEN, STLEN)
      IF (ERRIND .NE. 0) GOTO 950
      CALL PQECO (STRID, ELPOS, LINT, LRL, LSTR, ERRIND, INTG,
     1            INTAR, RL, RLAR, STR, STRL, STRAR)
      CALL CHKINQ ('pqeco', ERRIND)

      IF (ELTYPE .EQ. PEEXST .OR.
     1    ELTYPE .EQ. PELB)      THEN
         WRITE (STRG(NXCHAR : NXCHAR + 2), '(I2, A)') ELTYPE, ','
         NXCHAR = NXCHAR + 3
      ELSE
         CALL NCMSG ('Problem with the element type ' //
     1               'in subroutine elstr.')
      ENDIF

      WRITE (STRG(NXCHAR:NXCHAR+3),'(I3, A)') INTAR(1), ','
      NXCHAR = NXCHAR + 4

      ELPOS = ELPOS + 1
      GOTO 900

 950  CONTINUE
      STRG(NXCHAR-1:) = ' '

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 02.01.03/actst                          *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE ACTST (ACSTID, STRG, EXPCON,
     1                  OPSTRA, CONTOK, PSTSTA, PSTPRI)

C     Input Parameters :
C     INTEGER   acstid   structure identifier
C     CHARACTER strg     string identifying expected element type
C                        and content for structure acstid
C     INTEGER   expcon   expected contents: (NOEXE, NORG, NEMP)

C     Output Parameters:
C     INTEGER opstra     open structure indicator     (NOEXE, NOPEN, NCLOS)
C     LOGICAL contok     structure contents as expected
C     INTEGER pststa     posted structure indicator   (NOEXE, NPST, NNPT)
C     INTEGER pstpri     posted structure priority

C ACTST returns values indicating if a structure is non-existent
C open, closed, empty, original, and posted, not posted.

      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

C open-structure status:
C                none-open   open-structure
      INTEGER    PNONST,     POPNST
      PARAMETER (PNONST = 0, POPNST = 1)

C structure status indicator:
C                non-existent,  empty,      non-empty
      INTEGER    PSNOEX,        PSEMPT,     PSNEMP
      PARAMETER (PSNOEX = 0,    PSEMPT = 1, PSNEMP = 2)

C Enumeration values for subroutine parameters:
C   structure state: non-existent   opened       closed
      INTEGER        NOEXE,         NOPEN,       NCLOS
      PARAMETER     (NOEXE = -1,    NOPEN = 0,   NCLOS = 1)

C   structure posted state:
C                    structure posted     structure not posted
      INTEGER         NPST,                NNPT
      PARAMETER      (NPST = 0,            NNPT = 1)

C   structure reference status:
C                    referenced  not referenced
      INTEGER        NREF,       NNRF
      PARAMETER     (NREF = 2,   NNRF = 3)

C   structure contents:
C                    empty     original  bad-contents
      INTEGER        NEMP,     NORG,     NBCON
      PARAMETER     (NEMP = 0, NORG = 1, NBCON = -66)

      CHARACTER STRG*(*)

      INTEGER IDSTR, STYPE, OPSTRA, EXPCON, PSTSTA, POSTNM,
     1        IEXIST, IDUM2, ACSTID, STRID, PSTLT

      REAL    RDUM1, PSTPRI

      LOGICAL STRCON, CONTOK

C determine if a structure is empty, non-existent, has the original
C contents, or none of these.
      CALL PQSTST (ACSTID, ERRIND, IEXIST)
      CALL CHKINQ ('pqstst', ERRIND)

      IF (IEXIST .EQ. PSNOEX) THEN
C non-existent
         OPSTRA = NOEXE
         CONTOK = (EXPCON .EQ. NOEXE)
         PSTSTA = NOEXE
         PSTPRI = 0.0
         RETURN
      ENDIF

C set CONTOK = contents OK
      CONTOK = ((EXPCON .EQ. NEMP) .AND. (IEXIST .EQ. PSEMPT)) .OR.
     1         ((EXPCON .EQ. NORG) .AND. (STRCON (ACSTID, STRG)))

C determine if a structure is opened or closed
      CALL PQOPST (ERRIND, STYPE, IDSTR)
      CALL CHKINQ ('pqopst', ERRIND)
      IF (STYPE .EQ. POPNST  .AND.
     1    IDSTR .EQ. ACSTID)   THEN
         OPSTRA = NOPEN
      ELSE
         OPSTRA = NCLOS
      ENDIF

C determine if a structure is posted or not
      PSTSTA = NNPT
      CALL PQPOST (WKID, 0, ERRIND, POSTNM, IDUM2, RDUM1)
      CALL CHKINQ ('pqpost', ERRIND)
      DO 200 PSTLT = 1, POSTNM
         CALL PQPOST (WKID, PSTLT, ERRIND, IDUM2, STRID, PSTPRI)
         CALL CHKINQ ('pqpost', ERRIND)
         IF (STRID .EQ. ACSTID) THEN
             PSTSTA = NPST
             GOTO 210
         ENDIF
200   CONTINUE
210   CONTINUE

      END


text:
## Honestly, YOU CAN DO BETTER THAN THIS!!!

Cinco de Mayo, Spanish for 5th of May, is a popular holidays holiday ostensibly celebrating the May 5, 1862, victory of the Mexican army over the French at the Battle of Puebla.  In the U.S., it has become a holiday analogous to St. Patricks Day.  That is to say, some people celebrate culture and heritage, while other get alcohol plastered and yell happy Drinko de Mayo downtown at passersby.  Many Mexican Food Mexican restaurants offer drink and/or food specials, and most of the bars in town do a great deal of business.

In 2011, Yolo County law enforcement stepped up enforcement.  Davis police made two DUI arrests and two controlled substance arrests.  Moral of the story?  Celebrate safely.