text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 04.02.05.04/03                        *
C  *    TEST TITLE : Pattern table length                  *
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

      INTEGER   MPAI, MPTE, NDE, MDPI, NEMP, II, PAI
C set up pattern color index array
      INTEGER    DIMX, DIMY, ISC, ISR, DX, DY
      PARAMETER  (DIMX = 100, DIMY = 100, ISC=1, ISR=1, DX=2, DY=2)
      INTEGER    COLIA(DIMX,DIMY)
      INTEGER   IDUM1, IDUM2, IDUM3, IDUM4, IDUM5, IDUM6, IDUM7

C type of returned value
      INTEGER    PSET,     PREALI
      PARAMETER (PSET = 0, PREALI = 1)

C interior style
      INTEGER    PHOLLO,   PSOLID,   PPATTR,   PHATCH,   PISEMP
      PARAMETER (PHOLLO=0, PSOLID=1, PPATTR=2, PHATCH=3, PISEMP=4)

      LOGICAL   NOPAT, PATAVL

C parameters for <inquire workstation connection and type>
      INTEGER   SPECWT, SPECON

      CHARACTER MSG*300

      CALL INITGL ('04.02.05.04/03')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)
C open workstation
      CALL POPWK  (WKID, CONID, WTYPE)
      CALL PQWKC  (WKID, ERRIND, SPECON, SPECWT)
      CALL CHKINQ ('pqwkc', ERRIND)

      NOPAT = .NOT. PATAVL(SPECWT)
      IF (NOPAT) THEN
         CALL INMSG ('Pattern interior style is not supported ' //
     1               'on this workstation.')
      ENDIF

      MPAI = -6
      CALL PQWKSL (SPECWT, ERRIND, IDUM1, IDUM2, IDUM3, IDUM4,
     1             IDUM5, MPAI, IDUM6, IDUM7)
      CALL CHKINQ ('pqwksl', ERRIND)

C maximum number of pattern table entries
      MPTE = MPAI

C  nde  = number of defined entries
C  mdpi = maximum defined pattern index
C  nemp = number of empty entries

      IF (NOPAT) THEN
         CALL SETMSG ('8 9', 'If PATTERN interior style is not '     //
     1                'supported, <inquire workstation state table ' //
     2                'lengths> should report 0 entries as maximum ' //
     3                'size of pattern table.')
         CALL IFPF (MPTE .EQ. 0)
         GOTO 666
      ENDIF

      CALL SETMSG ('8 10', 'If PATTERN interior style is supported, ' //
     1             '<inquire workstation state table lengths> '       //
     2             'should report at least 10 entries as maximum '    //
     3             'size of pattern table.')

      CALL IFPF (MPTE .GE. 10)

      CALL PQEPAI (WKID, 0, ERRIND, NDE, IDUM1)
      CALL CHKINQ ('pqepai', ERRIND)
      MDPI = -9999
      DO 100 II = 1, NDE
         CALL PQEPAI (WKID, II, ERRIND, IDUM1, PAI)
         CALL CHKINQ ('pqepai', ERRIND)
         IF (PAI .GT. MDPI) MDPI = PAI
100   CONTINUE

C set up values for pattern color index array
      COLIA(1,1) = 97
      COLIA(2,1) = 5
      COLIA(1,2) = 33
      COLIA(2,2) = 53

      NEMP = MPTE - NDE

      CALL SETMSG ('8', 'The program should be able to define ' //
     1             'additional pattern table entries, up '      //
     2             'to the maximum.')
C  set new entries
      CALL ERRCTL (.TRUE.)
      DO 250 PAI = MDPI+1, MDPI+NEMP
         CALL PSPAR (WKID, PAI, DIMX, DIMY, ISC, ISR, DX, DY, COLIA)
         IF (ERRSIG .NE. 0) THEN
            CALL FAIL
            WRITE (MSG, '(A,I6,A)')
     1      'Unable to fill pattern table slot #', NDE+PAI-MDPI,'.'
            CALL INMSG (MSG)
            GOTO 300
         ENDIF
250   CONTINUE
      CALL PASS

300   CONTINUE
      CALL ERRCTL (.FALSE.)

666   CONTINUE
      CALL ENDIT
      END


text:
      SUBROUTINE NSINFO (JUMP)
C
C     THIS ROUTINE READS AND PROCESSES DATA IN THE NASINFO FILE
C
C     JUMP = 2, NSINFO IS CALLED BY NASCAR TO OPEN NASINFO FILE AND
C               PROCESS THE SYSTEM PRESET PARAMETERS IN THE 2ND SECTION
C               OF THE FILE, AND THE BCD WORDS (USED ONLY BY NUMTYP
C               SUBROUTINE) IN THE 3RD SECTION
C     JUMP = 3, NSINFO IS CALLED BY TTLPGE TO PROCESS THE INSTALLATION-
C               CENTER-TO-USER MESSAGES STORED IN THE 4TH SECTION OF
C               THE NASINFO FILE
C     JUMP = 4, NSINFO IS CALLED BY XCSA TO ECHO DIAG 48 MESSAGE STORED
C               IN THE 5TH SECITON OF THE NASINFO FILE.
C
C     SINCE DIAG48 MAY NOT BE CALLED, NASINFO FILE IS CLOSED BY XCSA
C
C     WRITTEN BY G.CHAN/UNISYS    6/1990
C
      IMPLICIT INTEGER (A-Z)
CWKBR 8/94 SUN INTEGER         NAME(2),NTAB(5),CARDX(4),CARD(20),DIAG48(4)
      INTEGER         NAME(2),CARDX(4),CARD(20),DIAG48(4)
      REAL            TIME
CWKBR CHARACTER*167   IFILE
      CHARACTER*144   IFILE
      CHARACTER       UFM*23,UWM*25,UIM*29,SFM*25
      COMMON /XMSSG / UFM,UWM,UIM,SFM
      COMMON /MACHIN/ MACH
      COMMON /SYSTEM/ SYS(100)
      COMMON /NTIME / NT,TIME(16)
      COMMON /OUTPUT/ DUM(64),PGHDG3(32)
      COMMON /NUMTPX/ NBCD,BCD(1)
      COMMON /BLANK / IBLNK(60)
      EQUIVALENCE     (CARDX(1),CARD(1))
      EQUIVALENCE     (SYS(1),SYSBUF), (SYS( 2),NOUT), (SYS( 9),NLPP  ),
     1                (SYS(14),MXLNS), (SYS(19),EHCO), (SYS(31),HICORE),
     2                (SYS(35),LPRUS), (SYS(37),LU  ), (SYS(36),NPRUS ),
     3                (SYS(20),PLTOP), (SYS(92),DICT), (SYS(76),NOSBE ),
     4                (SYS(77),BNDIT), (SYS(91),LPCH)
      DATA    TTPG     / 0            /
CWKBR 8/94 SUN DATA    EQU   , R  ,  S  ,  BNK      ,   EQUALS   , NAME         /
CWKBR 8/94 SUN1        1H=   , 1HR,  1HS,  4H       ,   4H====   , 4HNSIN,2HFO  /
      DATA    EQU   , S  ,  BNK      ,   EQUALS   , NAME         /
     1        1H=   , 1HS,  4H       ,   4H====   , 4HNSIN,2HFO  /

      DATA    RELSE , TPG,  POP,  TIM,  MXL,   BSZ      , S3S   ,SKP3  /
     1        4HELEA, 3HTPG,3HPOP,3HTIM,3HMXL, 3HBSZ    , 3HS3S ,0     /
      DATA    LPP   , HIC,  BND,  ECH,  NOS,   PRU,  NPR,  PCH,  END   /
     1        3HLPP , 3HHIC,3HBND,3HECH,3HNOS, 3HPRU,3HNPR,3HPCH,3HEND /
      DATA    S88   , S89,  S90,  S92,  S94,   S96,  S97,  S98,  S99   /
     1        3HS88 , 3HS89,3HS90,3HS92,3HS94, 3HS96,3HS97,3HS98,3HS99 /
      DATA    DIAG48                         , DD   ,DIC  ,COD  ,KEY   /
     1        4H D I, 4H A G, 4H   4, 2H 8   , 3H$. ,3HDIC,3HCOD,3HKEY /
C
      GO TO (550,200,350,400), JUMP
C
C     JUMP = 2
C     ========
C
C     OPEN NASINFO FILE, AND SET LU, THE 37TH WORD OF /SYSTEM/
C
C     CURRENTLY 'NASINFO' IS USED FOR ALL MACHINES OF TYPE 5 AND HIGHER
C
 200  LU  = 99
      CALL NASOPN (*280, LU, IFILE)
C
C     SEARCH FOR FIRST EQUAL-LINE
C
 210  READ (LU,220,ERR=275,END=275) CARDX
 220  FORMAT (20A4)
      IF (CARD(1).NE.EQUALS .AND. CARD(2).NE.EQUALS) GO TO 210
C
C     READ AND PROCESS THE 2ND SECTION OF NASINFO FILE
C
 230  READ (LU,235,END=500) SYMBOL,EQ,VALUE
 235  FORMAT (A4,A1,I7)
      IF (SYMBOL .EQ. BNK) GO TO 230
      IF (EQ     .NE. EQU) GO TO 520
      IF (SYMBOL .EQ. TIM) GO TO 250
      IF (SYMBOL .EQ. END) GO TO 290
      IF (VALUE  .EQ. -99) GO TO 230
      IF (SYMBOL .EQ. S3S) GO TO 240
      IF (SYMBOL .EQ. BSZ) SYSBUF  = VALUE
      IF (SYMBOL .EQ. LPP) NLPP    = VALUE
      IF (SYMBOL .EQ. HIC) HICORE  = VALUE
      IF (SYMBOL .EQ. MXL) MXLNS   = VALUE
      IF (SYMBOL .EQ. TPG) TTPG    = VALUE
      IF (SYMBOL .EQ. ECH) ECHO    = VALUE
      IF (SYMBOL .EQ. PCH) LPCH    = VALUE
      IF (SYMBOL .EQ. DIC) DICT    = VALUE
      IF (SYMBOL .EQ. BND) BNDIT   = VALUE
      IF (SYMBOL .EQ. POP) PLTOP   = VALUE
      IF (SYMBOL .EQ. PRU) LPRUS   = VALUE
      IF (SYMBOL .EQ. NPR) NPRUS   = VALUE
      IF (SYMBOL .EQ. NOS) NOSBE   = VALUE
      IF (SYMBOL .EQ. COD) CODE    = VALUE
      IF (SYMBOL .EQ. KEY) KEY     = VALUE
      SYMB1 = KHRFN1(BNK,1,SYMBOL,1)
      IF (SYMB1  .NE.   S) GO TO 230
      IF (SYMBOL .EQ. S88) SYS(88) = VALUE
      IF (SYMBOL .EQ. S89) SYS(89) = VALUE
      IF (SYMBOL .EQ. S90) SYS(90) = VALUE
      IF (SYMBOL .EQ. S92) SYS(92) = VALUE
      IF (SYMBOL .EQ. S94) SYS(94) = VALUE
      IF (SYMBOL .EQ. S96) SYS(96) = VALUE
      IF (SYMBOL .EQ. S97) SYS(97) = VALUE
      IF (SYMBOL .EQ. S98) SYS(98) = VALUE
      IF (SYMBOL .EQ. S99) SYS(99) = VALUE
      GO TO 230
C
C     SKIP JUMP 3 PRINTOUT
C
 240  SKP3 = 1
      GO TO 230
C
C     READ IN 16 GINO TIME CONSTANTS (NT=16)
C
 250  IF (VALUE .NE. NT) GO TO 270
      READ (LU,260,END=500) TIME
 260  FORMAT (12X,8F7.2, /12X,8F7.2)
      GO TO 230
 270  READ (LU,235,END=500) SYMBOL
      READ (LU,235,END=500) SYMBOL
      GO TO 230
C
C     NASINFO DOES NOT EXIST (or IS WRITE-PROTECTED), SET LU TO ZERO
C
 275  CLOSE (UNIT=LU)
      CALL MESAGE (2,0,NAME)
 280  WRITE (NOUT, 285) IFILE
 285  FORMAT ('0*** USER WARNING MESSAGE, UNABLE TO OPEN ',
     *        'THE FOLLOWING NASINFO FILE -- '//
CWKBR*        1X, A167/)
     *        1X, A44/)
      LU = 0
      GO TO 550
C
C     READ PASS THE 2ND EQUAL-LINE. CONTINUE INTO 3RD SECTION
C
 290  READ (LU,220,END=500) CARDX
      IF (CARD(1).NE.EQUALS .AND. CARD(2).NE.EQUALS) GO TO 290
C
C
C     THIS 3RD SECTION CONTAINS BCD WORDS WHICH ARE REALLY REAL NUMBERS.
C     (THE BINARY REPRESENTATIONS OF SOME REAL NUMBERS AND THEIR
C     CORRESPONDING BCD WORDS ARE EXACTLY THE SAME. SUBROUTINE NUMTYP
C     MAY IDENTIFY THEM AS TYPE BCD. ANY WORD ON THE BCD LIST WILL BE
C     REVERTED BACK TO AS TYPE REAL. THE LIST IS MACHINE DEPENDENT)
C
C     SKIP FIRST 5 COMMENT LINES
C
      READ (LU,220,END=500)
      READ (LU,220)
      READ (LU,220)
      READ (LU,220)
      READ (LU,220)
C
 300  READ (LU,305,END=500) MACHX,NBCD
 305  FORMAT (I2,I3)
      IF (MACHX .EQ. MACH) GO TO 320
      IF (NBCD .EQ. 0) GO TO 300
      DO 310 I = 1,NBCD,19
      READ (LU,325)
 310  CONTINUE
      GO TO 300
 320  IF (NBCD .EQ. 0) GO TO 340
      JB = 1
      DO 330 I = 1,NBCD,19
      JE = JB + 18
      READ (LU,325) (BCD(J),J=JB,JE)
 325  FORMAT (5X,19(A4,1X))
 330  CONTINUE
C
C     READ PASS THE 3RD EQUAL-LINE, THEN RETURN
C
 340  READ (LU,220,END=500) CARDX
      IF (CARD(1).NE.EQUALS .AND. CARD(2).NE.EQUALS) GO TO 340
      IF (TTPG .NE. 0) JUMP = TTPG
      GO TO 550
C
C     JUMP = 3
C     ========
C
C     READ AND ECHO OUT INSTALLATION-CENTER-TO-USER MESSAGES, SAVED IN
C     THE 4TH SECTION OF NASINFO FILE
C     TERMINATE MESSAGES BY THE LAST EQUAL-LINE.
C
C     IN THIS MESSAGE SECTION ONLY, SKIP INPUT LINE IF A '$.  ' SYMBOL
C     IS IN FIRST 4 COLUMNS.
C
 350  IF (LU.EQ.0 .OR. SKP3.EQ.1) GO TO 550
      CALL PAGE1
 360  READ (LU,220,END=500) CARD
      IF (CARD(1) .EQ.     DD) GO TO 360
      IF (CARD(1) .NE. EQUALS) GO TO 380
      IF (CARD(2) .EQ. EQUALS) GO TO 550
      CALL PAGE1
      WRITE  (NOUT,370)
 370  FORMAT (//)
      GO TO 360
 380  WRITE  (NOUT,390) CARD
 390  FORMAT (25X,20A4)
      GO TO 360
C
C     JUMP = 4
C     ========
C
C     PROCESS DIAG48 MESSAGE, SAVED IN THE 5TH SECTION OF NASINFO FILE
C
 400  CALL SSWTCH (20,L20)
      IF (LU .EQ. 0) GO TO 480
      DO 410 I = 10,20
 410  PGHDG3(I) = BNK
      PGHDG3(6) = DIAG48(1)
      PGHDG3(7) = DIAG48(2)
      PGHDG3(8) = DIAG48(3)
      PGHDG3(9) = DIAG48(4)
      LINE  = NLPP + 1
      COUNT = 0
C
C     READ AND PRINT RELEASE NEWS
C     PRINT LAST TWO YEARS OF NEWS ONLY, IF DIAG 20 IS ON
C     (MECHANISM - GEAR TO THE 'nn RELEASE' LINE AND '========' LINES)
C
      ONE = 1
      IF (L20 .EQ. 1) ONE = 0
 420  READ (LU,220,END=540) CARD
      IF (CARD(1).EQ.EQUALS .AND. CARD(2).EQ.EQUALS) GO TO 470
      IF (ONE .EQ. -1) GO TO 440
      IF (CARD(2).NE.RELSE  .OR.  CARD(4).NE.   BNK) GO TO 440
      COUNT = COUNT + ONE
      IF (COUNT .LE. 2) GO TO 440
 430  READ (LU,220,END=540) CARDX
      IF (CARD(1).NE.EQUALS .OR. CARD(2).NE.EQUALS) GO TO 430
      GO TO 470
 440  IF (LINE .LT. NLPP) GO TO 460
      CALL PAGE1
      IF (LINE .EQ. NLPP) GO TO 450
      LINE = 3
      GO TO 460
 450  WRITE (NOUT,370)
      LINE = 5
 460  LINE = LINE + 1
      WRITE (NOUT,390) CARD
      GO TO 420
C
C     READ AND PRINT THE REST OF SECTION 5
C
 470  IF (ONE .EQ. -1) GO TO 540
      ONE  = -1
      LINE = NLPP + 1
      GO TO 420
C
 480  WRITE  (NOUT,490) UIM
 490  FORMAT (A29,', DIAG48 MESSAGES ARE NOT AVAILABLE DUE TO ABSENCE ',
     1       'OF THE NASINFO FILE')
      GO TO 540
C
C     ERROR
C
 500  WRITE  (NOUT,510) SFM
 510  FORMAT (A25,' 3002, EOF ENCOUNTERED WHILE READING NASINFO FILE')
      STOP 'JOB TERMINATED IN SUBROUTINE NSINFO'
 520  WRITE  (NOUT,530) SYMBOL,EQ,VALUE
 530  FORMAT ('0*** ERROR IN NASINFO FILE - LINE - ',A4,A1,I7)
      GO TO 230
C
 540  IF (L20 .EQ. 0) GO TO 550
      CLOSE (UNIT=LU)
      CALL PEXIT
 550  RETURN
      END

ext: f


text: include '../../normal/input/m1.inc'

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/38883
! This ICE'd because the temporary-creation in the MVBITS call was wrong.
! This is the original test from the PR, the complicated version.

! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>

     module yg0009_stuff

      type unseq
         integer I
      end type

      contains

      SUBROUTINE YG0009(TDA2L,NF4,NF3,NF1,MF1,MF4,MF3)
        TYPE(UNSEQ) TDA2L(NF4,NF3)

        CALL MVBITS (TDA2L(NF4:NF1:MF1,NF1:NF3)%I,2, &
          4, TDA2L(-MF4:-MF1:-NF1,-MF1:-MF3)%I, 3)

      END SUBROUTINE

      end module yg0009_stuff

      program try_yg0009
      use yg0009_stuff
      type(unseq)  tda2l(4,3)

      call yg0009(tda2l,4,3,1,-1,-4,-3)

      end


text:
C Copyright(C) 1999-2020 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 See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE CKCNTR (OK)
C=======================================================================

C   --*** CKCNTR *** (DETOUR) Check the contour values
C   --   Written by Amy Gilkey - revised 07/10/87
C   --
C   --CKCNTR checks that all specified contour values increase or decrease.
C   --
C   --Parameters:
C   --   OK - OUT - true iff the contour values are consistent
C   --
C   --Common Variables:
C   --   Uses CINTOK, LINCON, NCNTR, CINTV of /CNTR/

      include 'cntr.blk'
C     FLAG FOR EXACT CONTOUR VALUES FOR EACH PLOT
C     COMMON /CNTR/   CINTOK, LINCON, NCNTR, CMIN, CMAX, DELC,
C    &   CINTV(256), NOCMIN, NOCMAX, LABINC, MAXMIN, MAXMAX
C     LOGICAL CINTOK, LINCON, NOCMIN, NOCMAX

      LOGICAL OK

      CHARACTER*80 ERRSTR

      OK = .TRUE.

      IF (CINTOK) THEN
         IF (LINCON) THEN
            NC = NCNTR
         ELSE
            NC = NCNTR+1
         END IF

         IF (CINTV(1) .LE. CINTV(2)) THEN
            DO 100 I = 2, NC
               IF (CINTV(I-1) .GE. CINTV(I)) THEN
                  WRITE (ERRSTR, 10000)
     &               'Contour interval ', I-1, ' >= interval ', I
10000             FORMAT (A, I5, A, I5)
                  CALL SQZSTR (ERRSTR, LSTR)
                  CALL PRTERR ('CMDWARN', ERRSTR(:LSTR))
                  OK = .FALSE.
               END IF
  100       CONTINUE
         ELSE
            DO 110 I = 2, NC
               IF (CINTV(I-1) .LE. CINTV(I)) THEN
                  WRITE (ERRSTR, 10000)
     &               'Contour interval ', I-1, ' <= interval ', I
                  CALL SQZSTR (ERRSTR, LSTR)
                  CALL PRTERR ('CMDWARN', ERRSTR(:LSTR))
                  OK = .FALSE.
               END IF
  110       CONTINUE
         END IF
      END IF

      RETURN
      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
program a_plus_b
  implicit none
  integer :: a,b
  read (*, *) a, b
  write (*, '(i0)') a + b
end program a_plus_b

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text: Graduated with Honors, major in Biochemistry and Molecular Biology and minors in English and Technology Management.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


module potential

  use progvars

  use precision, only: ip, fp

  implicit none

  public :: potential_xyt

contains

  pure complex(fp) function potential_xyt(i_x, i_y, i_t) result(val)
    integer(ip), intent(in) :: i_x, i_y, i_t

    val = potential_sc_coulomb_2d(i_x, i_y)

    if (i_t > 0_ip) then
       val = val + potential_gobbler_quartic_2d(i_x, i_y)
       val = val + potential_sin2_pulse_2d(i_x, i_y, i_t)
    end if

  end function potential_xyt

  pure real(fp) function potential_sin2_pulse_2d(i_x, i_y, i_t) result(val)
    integer(ip), intent(in) :: i_x, i_y, i_t

    real(fp) :: x, y, t

    real(fp) :: env, pol, int
    real(fp) :: t_ramp, t_plat, t_c
    real(fp) :: phi, omega

    real(fp) :: pulse

    x = x_range(i_x)
    y = y_range(i_y)
    t = t_range(i_t)

    int = pulse_intensity
    t_ramp = pulse_t_ramp
    t_plat = pulse_t_plateau

    phi = pulse_phi
    omega = pulse_omega

    ! Pulse envelope
    if (t .lt. t_ramp) then
       ! sin^2 envelope on up ramp
       env = sin(pi / 2.0_fp * t / t_ramp)**2
    else if (t .ge. t_ramp .and. t .le. t_ramp + t_plat) then
       ! constant envelope on plateau
       env = 1.0_fp
    else if (t .gt. t_ramp + t_plat .and. t .le. 2 * t_ramp + t_plat) then
       ! sin^2 envelope on down ramp
       env = sin(pi / 2.0_fp * (t - t_plat)/t_ramp)**2
    else
       env = 0.0_fp
    end if

    ! Right circular polarization
    pol = 1.0_fp

    t_c = t_ramp + t_plat / 2.0_fp

    pulse = env * sqrt(int)

    ! Dipole approximation: V = -q \vec{r} \dot \vec{E(t)}
    ! Here, q = -q_e
    val = pulse * ( x * cos(omega * (t - t_c) + pulse_phi) + &
         y * sin(omega * (t - t_c) + pulse_phi) )

  end function potential_sin2_pulse_2d

  pure real(fp) function potential_sc_coulomb_2d(i_x, i_y) result(val)
    integer(ip), intent(in) :: i_x, i_y

    real(fp) :: offset, depth
    real(fp) :: x, y

    x = (x_range(i_x) - sc_coulomb_x0)
    y = (y_range(i_y) - sc_coulomb_y0)

    val = - sc_coulomb_depth / sqrt(x**2 + y**2 + sc_coulomb_offset**2)

  end function potential_sc_coulomb_2d

  ! Negative imaginary gobbler
  pure complex(fp) function potential_gobbler_quartic_2d(i_x, i_y) result(val)

    integer(ip), intent(in) :: i_x, i_y

    integer(fp) :: delta_x, delta_y

    val = 0.0_fp

    if (i_x > vd_xr_max) then
       delta_x = x_range(i_x) - x_range(vd_xr_max)
       val = val * gobbler_strength_x * (delta_x / gobbler_width_y)**4
    else if (i_x < vd_xl_min) then
       delta_x = x_range(vd_xl_min) - x_range(i_x)
       val = val * gobbler_strength_x * (delta_x / gobbler_width_y)**4
    end if

    if (i_y > vd_yr_max) then
       delta_y = y_range(i_y) - y_range(vd_yr_max)
       val = val * gobbler_strength_x * (delta_y / gobbler_width_y)**4
    else if (i_x < vd_yl_min) then
       delta_y = y_range(vd_yl_min) - y_range(i_y)
       val = val * gobbler_strength_x * (delta_y / gobbler_width_y)**4
    end if

    val = -j * val

  end function potential_gobbler_quartic_2d

end module potential


module utility_crash

    use define_globals
    use define_indexes
    use define_keys
    use define_settings, only: setting

    implicit none

!%-----------------------------------------------------------------------------
!% Description:
!% Utility routines for code crash control
!% note that these cannot depend on anything except for define_globals so that it
!% can be called by any module except for defin_globals.f90
!%
!% USE: inside a conditional when a stop is needed use...
!%   call util_crashpoint(1093874) !% 1093874 is a unique index number for crash point
!%   This sets a "crash" condition where a single-processor code will immediately stop
!%   with the index number displayed at the command line (e.g., stop 1093874).
!%   However, for multiprocessor the crashpoint sets crashI=1 on the local processor,
!%   which ensures that at the next call to util_crashstop() that all processors
!%   will be stopped.
!%
!% USE: outside of conditionals a stop is called with...
!%   call util_crashtop(93872) !% 93872 is a unique index number for the crash point.
!%   This will check to see if crashI==1 on ANY processor, and if so it will stop
!%   all the processors.
!%-----------------------------------------------------------------------------

    private

    public :: util_crash_initialize
    public :: util_crashcheck
    public :: util_crashstop
    public :: util_crashpoint

    contains
!%
!%==========================================================================
!% PUBLIC
!%==========================================================================
!%
    subroutine util_crash_initialize
        !%------------------------------------------------------------------
        !% Description:
        !% sets up the conditions for identifying blow-up crash of the
        !% simulation
        !% uses the size of integer*2 as a reasonable limit
        !%------------------------------------------------------------------
        !% Declarations:
            integer*2 :: ilimit = 0
        !%------------------------------------------------------------------

        setting%Crash%DepthMax               = real(huge(ilimit),8)
        setting%Crash%HeadMax                = setting%Crash%DepthMax + maxval(elemR(:,er_Zbottom))
        setting%Crash%FlowrateMax            = real(huge(ilimit),8)
        setting%Crash%PercentVelocityAtLimit = tenR

    end subroutine util_crash_initialize
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine util_crashcheck (indexnumber)
        !%------------------------------------------------------------------
        !% Description:
        !% Checks for blow-up conditions and halts execution
        !%------------------------------------------------------------------
        !% Declarations:
            integer, intent(in) :: indexnumber
            integer :: depthloc, headloc, flowloc, nlarge
            real(8) :: depthmax, headmax, flowmax, percentU
            logical :: iscrash
        !%------------------------------------------------------------------

        iscrash = .false.

        call util_crash_nantest(iscrash)

        !% --- blow up tests for individual cells
        call util_crash_blowuptest (er_Depth,    setting%Crash%DepthMax,    'depth',    iscrash)
        call util_crash_blowuptest (er_Head,     setting%Crash%HeadMax,     'head',     iscrash)
        call util_crash_blowuptest (er_Flowrate, setting%Crash%FlowrateMax, 'flowrate', iscrash)

        !% --- blow up test for too many cells close to velocity limit
        nlarge = count(      (abs(elemR(1:N_elem(this_image()),er_Velocity)) .ge. 0.98d0* setting%Limiter%Velocity%Maximum) &
                       .and. (abs(elemR(1:N_elem(this_image()),er_Velocity)) .ne. nullvalueR)  )
        percentU = real(nlarge,8) * onehundredR / real(N_elem(this_image()),8)

        if (percentU .ge. setting%Crash%PercentVelocityAtLimit) then
            iscrash = .true.
            print *, ' '
            print *, '========================================================== ', this_image()
            print *, '               SIMULATION BLOWING UP'
            print *, 'Too many cells at artificial velocity limit'
            print *, nlarge, ' of ',N_elem(this_image()), ' cells on image ',this_image()
            print *, 'are at velocity near ',setting%Limiter%Velocity
        end if

        !% assign crashpoint
        if (iscrash) call util_crashpoint (indexnumber)

        !%------------------------------------------------------------------
    end subroutine util_crashcheck

!%==========================================================================
!%==========================================================================
!%
    subroutine util_crashstop (indexnumber)
        !%------------------------------------------------------------------
        !% Description:
        !% checks for a crash condition across processors and stops all
        !% processors if any one has encountered a crash condition
        !% Note: requires a sync, so should NOT be called inside a conditional
        !% such as select-case or if-then.
        !%------------------------------------------------------------------
        !% Declarations
            integer, intent(in) :: indexnumber !% unique ID of crash location
        !%------------------------------------------------------------------

        !% --- identify crash on the crashing image
        if (crashI == 1) then
            print *, 'crash stop originating at', indexnumber,' on image ',this_image()
        end if

        sync all
        !% broadcast to all images and stop all
        call co_max(crashI)
        if (crashI==1) then
            print *, 'stopping image ',this_image()
            stop indexnumber
        end if

    end subroutine util_crashstop
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine util_crashpoint (indexnumber)
        !%------------------------------------------------------------------
        !% Description:
        !% Creates immediate stop if this is a single processor run,
        !% otherwise prints the index number and sets the crashI=1 condition
        !%------------------------------------------------------------------
        !% Declarations
            integer, intent(in) :: indexnumber !% unique ID of crash location
        !%------------------------------------------------------------------
        crashI=1
        print *, 'crash point on image ',this_image(), ' at indexnumber...'
        print *, indexnumber
        if (num_images()==1) stop

    end subroutine util_crashpoint
!%
!%==========================================================================
!% PRIVATE
!%==========================================================================
!%
    subroutine util_crash_blowuptest (thisCol, thislimit, blowupType, iscrash)
        !%------------------------------------------------------------------
        !% Description:
        !% Provides blowup test for elem(:,thisCol) with limit thislimit
        !%------------------------------------------------------------------
        !% Declarations
            integer, intent(in)           :: thisCol
            real(8), intent(in)           :: thislimit
            logical, intent(inout)        :: iscrash
            character (len=*), intent(in) :: blowupType

            real(8), pointer              :: tempvalue(:)
            real(8) :: valuemax
            integer :: locOfMax(1), linknum, nodenum
        !%------------------------------------------------------------------
        !% Aliases
            tempvalue => elemR(:,er_Temp01)
        !%------------------------------------------------------------------
        !% --- store tempvalue with zeros for nullvalues
        tempvalue = abs(elemR(:,thisCol))
        where (tempvalue == nullvalueR)
            tempvalue = zeroR
        endwhere

        valuemax = maxval(tempvalue)
        locOfMax = maxloc(tempvalue)

        if (valuemax .ge. thislimit) then
            iscrash = .true.
            print *, ' '
            print *, '========================================================== ', this_image()
            print *, '                SIMULATION BLOWING UP'
            print *, trim(blowupType),' >    ',thislimit
            print *, 'at element index number', locOfMax
            print *, 'on image               ', this_image()
            linknum = elemI(locOfMax(1),ei_link_Gidx_SWMM)
            nodenum = elemI(locOfMax(1),ei_node_Gidx_SWMM)
            if (linknum .ne. nullvalueI) then
                print *, 'link index number is   ',linknum
                print *, 'SWMM input link ID is        ',trim(link%Names(linknum)%str)
            end if
            if (nodenum .ne. nullvalueI) then
                print *, 'node index number is  ',nodenum
                print *, 'SWMM input node ID is       ',trim(node%Names(nodenum)%str)
            end if
        end if

    end subroutine util_crash_blowuptest
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine util_crash_nantest (iscrash)
        !%------------------------------------------------------------------
        !% Description
        !% Tests for NaN values in the elemR array
        !% HACK -- should be expanded to faceR array as well
        !% HACK -- for comprehensive testing, we need to only do the static
        !% columns at the start, and then dynamic during the simulation.
        !%------------------------------------------------------------------
        !% Declarations:
            logical, intent(inout)        :: iscrash

            integer, pointer :: NN
            integer :: ii, kk

            character(len=14) :: ename(8)
            integer           :: eset(8)

            real(8) :: temp2(9), temp1(9)
        !%------------------------------------------------------------------
        !% Aliases
            NN => N_elem(this_image())
        !%------------------------------------------------------------------
        !% Preliminaries
            !% --- columns of elemR that will be checked for NaN
            eset = [er_Area, &
                    er_Depth, &
                    er_Flowrate, &
                    er_Head, &
                    er_Slotdepth, &
                    er_Velocity, &
                    er_Volume, &
                    er_WaveSpeed]

            ename = ['er_Area     ', &
                    'er_Depth    ', &
                    'er_Flowrate ', &
                    'er_Head     ', &
                    'er_Slotdepth', &
                    'er_Velocity ', &
                    'er_Volume   ', &
                    'er_WaveSpeed']
        !%------------------------------------------------------------------

        !% --- globally check for NaN where they shouldn't occur
        if (any(isnan(elemR(1:NN,eset)))) then
            iscrash = .true.
            !% --- cycle through the data types
            do ii=1,size(eset)
                if (any(isnan(elemR(1:NN,eset(ii))))) then
                    !% --- cycle through the individual elements
                    do kk=1,NN
                        if (isnan(elemR(kk,eset(ii)))) then
                            print *, 'NaN found in ',trim(ename(ii)),' on image ',this_image()
                            print *, 'element index ',kk
                        end if
                    end do
                end if
            end do
        end if

    end subroutine util_crash_nantest
!%
!%==========================================================================
!% END OF MODULE
!%==========================================================================
end module utility_crash


text:
C
C
      PROGRAM UNROLL09
C
      PARAMETER (N=100)
      REAL T(N)
C
      DO 10 I = 1, 4
         IF(I.EQ.M) GO TO 10
         T(I+N) = -2*I
 10   CONTINUE
C
      END


text:
!
! Crown Copyright 2014 AWE.
!
! This file is part of TyphonIO.
! Released under the BSD 3-clause license.
! For more details see license.txt
!

module TIO_Global_mod

  implicit none

  public

  ! ********************************************************************************************** !
  !
  ! Parameterized datatype kinds and properties:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Parameterized kinds:
  ! </NAME>
  ! <FAPI>
  ! <DATA> integer, parameter :: TIO_FILEK
  ! <DATA> integer, parameter :: TIO_OBJK
  ! <DATA> integer, parameter :: TIO_ERRK
  ! <DATA> integer, parameter :: TIO_IPK
  ! <DATA> integer, parameter :: TIO_LPK
  ! <DATA> integer, parameter :: TIO_SIZEK
  ! <DATA> integer, parameter :: TIO_STEPK
  ! <DATA> integer, parameter :: TIO_TIMEK
  ! <DATA> integer, parameter :: TIO_SHAPEK
  ! <DATA> integer, parameter :: TIO_STRLEN_F
  ! <DATA> integer, parameter :: TIO_MAXDIMS_F
  ! <DATA> integer, parameter :: TIO_NULL_F
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !

  integer, parameter :: TIO_FILEK     = 4       ! Must correspond with TIO_File_t
  integer, parameter :: TIO_OBJK      = 4       ! Must correspond with TIO_Object_t
  integer, parameter :: TIO_ERRK      = 4       ! Must correspond with TIO_t

  integer, parameter :: TIO_IPK       = 4       ! Cast in C wrapper, for integer args
  integer, parameter :: TIO_LPK       = 4       ! Cast in C wrapper, for logical/boolean args
  integer, parameter :: TIO_SIZEK     = 4       ! Cast in C wrapper, so can pick 4 or 8 byte here
  integer, parameter :: TIO_STEPK     = 4       ! Cast in C wrapper
  integer, parameter :: TIO_TIMEK     = 8       ! Cast in C wrapper
  integer, parameter :: TIO_SHAPEK    = 4       ! Must correspond with TIO_Shape_t

  integer, parameter :: TIO_STRLEN_F  = 64      ! = TIO_STRLEN from typhio_global.h
  integer, parameter :: TIO_MAXDIMS_F = 7       ! = TIO_MAXDIMS from typhio_global.h

  integer, parameter :: TIO_NULL_F    = -1      ! Generic null value

  ! ********************************************************************************************** !
  !
  ! Error return codes - copied straight out of tio_error.h:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
#include "tiof_errornumapi.inc"
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !

#include "tiof_errornum.inc"

  ! ********************************************************************************************** !
  !
  ! Datatypes:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Datatype specifiers:
  ! </NAME>
  ! <FAPI>
  ! <DATA> integer, parameter :: TIO_DATATYPE_NULL_F
  ! <DATA> integer, parameter :: TIO_REAL4_F
  ! <DATA> integer, parameter :: TIO_REAL8_F
  ! <DATA> integer, parameter :: TIO_INTEGER4_F
  ! <DATA> integer, parameter :: TIO_INTEGER8_F
  ! <DATA> integer, parameter :: TIO_LOGICAL_F
  ! <DATA> integer, parameter :: TIO_CHAR_F
  ! <DATA> integer, parameter :: TIO_STRING_F
  ! <DATA> integer, parameter :: TIO_SIZE_F
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !

  integer, parameter :: TIO_DATATYPE_NULL_F            = 1000
  integer, parameter :: TIO_REAL4_F                    = 1001
  integer, parameter :: TIO_REAL8_F                    = 1002
  integer, parameter :: TIO_INTEGER4_F                 = 1003
  integer, parameter :: TIO_INTEGER8_F                 = 1004
  integer, parameter :: TIO_LOGICAL_F                  = 1005    ! 4-byte logical = unsigned int
  integer, parameter :: TIO_CHAR_F                     = 1006
  integer, parameter :: TIO_STRING_F                   = 1007
  integer, parameter :: TIO_SIZE_F                     = 1008

  ! ********************************************************************************************** !
  !
  ! Type classes:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Datatype classes:
  ! </NAME>
  ! <FAPI>
  ! <DATA> integer, parameter :: TIO_TYPECLASS_NULL_F
  ! <DATA> integer, parameter :: TIO_TYPECLASS_INTEGER_F
  ! <DATA> integer, parameter :: TIO_TYPECLASS_REAL_F
  ! <DATA> integer, parameter :: TIO_TYPECLASS_STRING_F
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !

  integer, parameter :: TIO_TYPECLASS_NULL_F            = 2000
  integer, parameter :: TIO_TYPECLASS_REAL_F            = 2001
  integer, parameter :: TIO_TYPECLASS_INTEGER_F         = 2002
  integer, parameter :: TIO_TYPECLASS_STRING_F          = 2003

  ! ********************************************************************************************** !
  !
  ! Dimensions (actual numeric values):
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Dimensions:
  ! </NAME>
  ! <FAPI>
  ! <DATA> integer, parameter :: TIO_0D_F = 0
  ! <DATA> integer, parameter :: TIO_1D_F = 1
  ! <DATA> integer, parameter :: TIO_2D_F = 2
  ! <DATA> integer, parameter :: TIO_3D_F = 3
  ! <DATA> integer, parameter :: TIO_4D_F = 4
  ! <DATA> integer, parameter :: TIO_5D_F = 5
  ! <DATA> integer, parameter :: TIO_6D_F = 6
  ! <DATA> integer, parameter :: TIO_7D_F = 7
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !

  integer, parameter :: TIO_0D_F                       = 0
  integer, parameter :: TIO_1D_F                       = 1
  integer, parameter :: TIO_2D_F                       = 2
  integer, parameter :: TIO_3D_F                       = 3
  integer, parameter :: TIO_4D_F                       = 4
  integer, parameter :: TIO_5D_F                       = 5
  integer, parameter :: TIO_6D_F                       = 6
  integer, parameter :: TIO_7D_F                       = 7

  ! ********************************************************************************************** !
  !
  ! Ghosts (actual numeric values):
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer, parameter :: TIO_GHOSTS_NULL_F              = -1
  integer, parameter :: TIO_GHOSTS_NONE_F              = 0
  integer, parameter :: TIO_GHOSTS_ALL_F               = -2
!!$  integer, parameter :: TIO_GHOSTS_INTERNAL_F          = -3    ! Viz-only
!!$  integer, parameter :: TIO_GHOSTS_ONLY_F              = -4    ! Viz-only

  ! ********************************************************************************************** !
  !
  ! Access parameters:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Access mode specifiers:
  ! </NAME>
  ! <FAPI>
  ! <DATA> integer, parameter :: TIO_ACC_NULL_F                 = 90010
  ! <DATA> integer, parameter :: TIO_ACC_CREATE_F               = 90011
  ! <DATA> integer, parameter :: TIO_ACC_REPLACE_F              = 90012
  ! <DATA> integer, parameter :: TIO_ACC_READWRITE_F            = 90013
  ! <DATA> integer, parameter :: TIO_ACC_READONLY_F             = 90014
  ! <DATA> integer, parameter :: TIO_ACC_READWRITESTRICT_F      = 90015
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !

  integer, parameter :: TIO_ACC_NULL_F                 = 90010
  integer, parameter :: TIO_ACC_CREATE_F               = 90011
  integer, parameter :: TIO_ACC_REPLACE_F              = 90012
  integer, parameter :: TIO_ACC_READWRITE_F            = 90013
  integer, parameter :: TIO_ACC_READONLY_F             = 90014
  integer, parameter :: TIO_ACC_READWRITESTRICT_F      = 90015

  ! ********************************************************************************************** !
  !
  ! Meshtype parameters:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer, parameter :: TIO_MESH_NULL_F                = 90020
  integer, parameter :: TIO_MESH_QUAD_F                = 90021   ! = colinear
  integer, parameter :: TIO_MESH_QUAD_COLINEAR_F       = 90021
  integer, parameter :: TIO_MESH_QUAD_NONCOLINEAR_F    = 90022
  integer, parameter :: TIO_MESH_UNSTRUCT_F            = 90023
  integer, parameter :: TIO_MESH_POINT_F               = 90024

  ! ********************************************************************************************** !
  !
  ! Coordtype parameters:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer, parameter :: TIO_COORD_NULL_F               = 90030
  integer, parameter :: TIO_COORD_CARTESIAN_F          = 90031
  integer, parameter :: TIO_COORD_SPHERICAL_F          = 90032
  integer, parameter :: TIO_COORD_CYLINDRICAL_F        = 90033
  integer, parameter :: TIO_COORD_CYL_AXISYMMETRIC_F   = 90034

  ! ********************************************************************************************** !
  !
  ! Shape parameters:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer, parameter :: TIO_SHAPE_NULL_F               = 0       ! Values here muct match C
  integer, parameter :: TIO_SHAPE_POINT1_F             = -10
  integer, parameter :: TIO_SHAPE_BAR2_F               = -11
  integer, parameter :: TIO_SHAPE_TRI3_F               = -12
  integer, parameter :: TIO_SHAPE_QUAD4_F              = -13
  integer, parameter :: TIO_SHAPE_TET4_F               = -14
  integer, parameter :: TIO_SHAPE_WEDGE6_F             = -15
  integer, parameter :: TIO_SHAPE_HEX8_F               = -16
  integer, parameter :: TIO_SHAPE_PYR5_F               = -17
                                                                 ! More shapes may be
                                                                 ! added in future

  ! ********************************************************************************************** !
  !
  ! Centring parameters:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer, parameter :: TIO_CENTRE_NULL_F              = 90040
  integer, parameter :: TIO_CENTRE_CELL_F              = 90041
  integer, parameter :: TIO_CENTRE_EDGE_I_F            = 90042
  integer, parameter :: TIO_CENTRE_EDGE_J_F            = 90043
  integer, parameter :: TIO_CENTRE_EDGE_K_F            = 90044
  integer, parameter :: TIO_CENTRE_FACE_I_F            = 90045
  integer, parameter :: TIO_CENTRE_FACE_J_F            = 90046
  integer, parameter :: TIO_CENTRE_FACE_K_F            = 90047
  integer, parameter :: TIO_CENTRE_NODE_F              = 90048

  ! ********************************************************************************************** !
  !
  ! ArrayQuant dimension tags:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer, parameter :: TIO_ARRAYQ_DIM1_F              = -101
  integer, parameter :: TIO_ARRAYQ_DIM2_F              = -102
  integer, parameter :: TIO_ARRAYQ_DIM3_F              = -103
  integer, parameter :: TIO_ARRAYQ_CELL_F              = -104
  integer, parameter :: TIO_ARRAYQ_NODE_F              = -105

  ! ********************************************************************************************** !
  !
  ! Data transfer parameters:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer, parameter :: TIO_XFER_NULL_F                = 90050
  integer, parameter :: TIO_XFER_INDEPENDENT_F         = 90051
  integer, parameter :: TIO_XFER_COLLECTIVE_F          = 90052

  ! ********************************************************************************************** !
  !
  ! Verbose mode parameters:
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> Error codes:
  ! </NAME>
  ! <FAPI>
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer, parameter :: TIO_VERBOSE_NULL_F             = 90060
  integer, parameter :: TIO_VERBOSE_OFF_F              = 90061
  integer, parameter :: TIO_VERBOSE_ALL_F              = 90062
  integer, parameter :: TIO_VERBOSE_MASTER_F           = 90063

contains

  ! ********************************************************************************************** !
  !
  ! TIO_SizeOf_f
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> TIO_SizeOf
  ! </NAME>
  ! <FAPI>
  ! <DATA> integer function TIO_SizeOf_f( datatype )
  ! <DATA>
  ! <DATA>   integer, intent(in) :: datatype
  ! </FAPI>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer function TIO_SizeOf_f( datatype )

    implicit none

    integer, intent(in) :: datatype

    integer :: val

    call tio_sizeof_c( datatype, val )

    TIO_SizeOf_f = val

  end function TIO_SizeOf_f

  ! ********************************************************************************************** !
  !
  ! TIO_Get_TypeClass_f
  !
  ! <ITEM>
  ! <NAME>
  ! <DATA> TIO_Get_TypeClass
  ! </NAME>
  ! <FAPI>
  ! <DATA> integer function TIO_Get_TypeClass_f( datatype, typeclass )
  ! <DATA>
  ! <DATA>   integer, intent(in)  :: datatype
  ! <DATA>   integer, intent(out) :: typeclass
  ! </FAPI>
  ! <FDES>
  ! <DATA> The returned typeclass is given as one of the TypeClass parameters:
  ! <DATA>

  ! <DATA> TIO_TYPECLASS_INTEGER_F

  ! <DATA> TIO_TYPECLASS_FLOAT_F

  ! <DATA> TIO_TYPECLASS_STRING_F

  ! <DATA>

  ! </FDES>
  ! </ITEM>
  !
  ! ********************************************************************************************** !
  integer function TIO_Get_TypeClass_f( datatype, typeclass )

    implicit none

    integer, intent(in)  :: datatype
    integer, intent(out) :: typeclass

    integer(kind=TIO_ERRK) :: err

    call tio_get_typeclass_c( datatype, typeclass, err )

    TIO_Get_TypeClass_f = err

  end function TIO_Get_TypeClass_f

end module TIO_Global_mod

!
! EOF

ext: fpp

max_stars_repo_name: benjaminjeliot/typhonio

max_issues_repo_name: benjaminjeliot/typhonio

max_forks_repo_name: benjaminjeliot/typhonio


! { dg-do run }
! PR64432
program countem
  implicit none
  integer(1)    :: count1, irate1, mymax1
  integer(2)    :: count2, irate2, mymax2
  integer(4)    :: count4, irate4, mymax4
  real(4)       :: rrate4

  call system_clock(count=count1, count_rate=irate4, count_max=mymax4)
  if (count1.ne.-127.or.irate4.ne.0.or.mymax4.ne.0) call abort
  call system_clock(count=count1, count_rate=rrate4, count_max=mymax1)
  if (count1.ne.-127.or.rrate4.ne.0.0.or.mymax4.ne.0) call abort
  call system_clock(count=count2, count_rate=irate2, count_max=mymax2)
  if (count2.ne.-32767.or.irate2.ne.0.or.mymax2.ne.0) call abort
  call system_clock(count=count2, count_rate=rrate4, count_max=mymax2)
  if (count2.ne.-32767.or.rrate4.ne.0.0.or.mymax2.ne.0) call abort
  call system_clock(count=count4, count_rate=irate4, count_max=mymax4)
  if (irate4.ne.1000.or.mymax4.ne.huge(0_4)) call abort
  call system_clock(count=count4, count_rate=rrate4, count_max=mymax4)
  if (rrate4.ne.1000.0.or.mymax4.ne.huge(0_4)) call abort
end program countem


text:
*----------------------------------------------------------------------*
      subroutine update_reo(ireo,nel,
     &     idx1,idx2,idx_merge,imvleft,nmvleft)
*----------------------------------------------------------------------*
*     auxiliary routine: update reordering array [ireo(old) => new]
*     idx1 and idx2 are removed, instead idx_merge is inserted
*     imvleft(1:nmvleft) contains indices which must be left of
*     idx_merge in the new ordering
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     nel, idx1, idx2, idx_merge, nmvleft,
     &     imvleft(nmvleft)
      integer, intent(inout) ::
     &     ireo(nel)

      integer ::
     &     idx, ireo2(nel), idx_off, imv, inum, isub
      integer, external ::
     &     idxlist

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,'this is update_reo')
        write(lulog,'(x,a,10i5)') 'on input: ',ireo(1:nel)
        write(lulog,*) 'idx1, idx2: ', idx1, idx2
        write(lulog,*) 'idx_merge:  ',idx_merge
        write(lulog,*) 'imvleft:    ',imvleft(1:nmvleft)
      end if

      if (idx2.le.idx1 .or. idx_merge.lt.idx1 .or. idx_merge.gt.idx2)
     &     call quit(1,'update_reo','error 1')

      ! set up new permutation vector
      do idx = 1, nel
        ireo2(idx) = idx
      end do

      do idx = idx1, idx_merge-1
        ireo2(idx) = ireo2(idx+1)
      end do
      ireo2(idx_merge) = idx1
      ireo2(idx2) = 0
c      do idx = idx2+1, nel
c        ireo2(idx) = ireo2(idx)-1
c      end do

      if (ntest.ge.100) then
        write(lulog,*) 'ireo2: ',ireo2(1:nel)
      end if

      ! apply to ireo
c      call perm_mult(ireo,ireo,ireo2,nel)
      ! I assume this is better:
      call perm_mult(ireo,ireo,ireo2,nel)

      if (ntest.ge.100) then
        write(lulog,*) 'new ireo: ',ireo(1:nel)
      end if

      ! ensure 1-increment:
      ! e.g.  1 3 0 4  -->  1 2 0 3
      inum = 0
      isub = 0
      do while (inum.lt.nel)
        inum = inum+1
        idx = idxlist(inum,ireo,nel,1)
        if (idx.gt.0) then
          ireo(idx) = inum-isub
        else
          isub = isub+1
        end if
      end do

      if (ntest.ge.100) then
        write(lulog,*) 'mod. ireo: ',ireo(1:nel)
      end if

      ! reset permutation vector ...
      do idx = 1, nel
        ireo2(idx) = idx
      end do

      ! an set up permutation for imvleft
      idx_off = idx_merge
      do imv = 1, nmvleft
        do idx = idx_off+imv+1, imvleft(imv)
          ireo2(idx) = ireo2(idx-1)
        end do
        ireo2(idx_off+imv) = imvleft(imv)
      end do

      if (ntest.ge.100) then
        write(lulog,*) 'ireo2: ',ireo2(1:nel)
      end if

      call perm_mult(ireo,ireo,ireo2,nel)

      if (ntest.ge.100) then
        write(lulog,*) 'final ireo: ',ireo(1:nel)
      end if

      return
      end

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


text:
The Off Campus Meal Plan was a prepaid dining plan for students that allowed them to eat at noncampus restaurants as well as on many restaurants oncampus.  It was replace in fall of 2007 with the Aggie Cash system. Do not confuse this with the http://www.sodexho.ucdavis.edu/dining/offcamp.htm On Campus Meal Plan which is named the Off Campus Meal Plan. Clear? They said it worked similar to the campus Dining Commons, though its probably quite a bit different.  Unlike the DC meal plan, pricing is never a constant in restaurants.  The card has a set swipe value of $6.25. If you order $9.50 of food, they will do a swipe and a half.  This means that you wont necessarily get what you pay for due to rounding up of values. (Something that costs $8.50 may count the same as something that costs $10).  The OCMP offsets that by having special deals with many of its restaurants, however which ones are still unknown. They have promised to set some exclusive discount deals to members for values more than $6.25 but only count as one swipe anyway!

You can also call and make a custom plan over the phone if you only eat at certain types of restaurants, for example vegetarian options vegetarian restaurants.

 Pricing
To get an idea of the high and low ends of the price range for a semester (Sept. 26th to end of Dec.):

 The Supplemental Meal Plan is 35 meals (2 to 3 a week) at $239.34 (including tax).
     $240 / $6.25  about 38.5 meals.
  The TwentyOne Meal Plan is 21 meals a week (294 total) at $1858.74 (including tax).
    $1860 / $6.25  about 297 meals.

Its not any cheaper to buy it in bulk, its actually is more expensive.  There is also a $25 sign up fee.

 Restaurants that Participated
  Bakers Square
  Ben & Jerrys
  Bio Brew  On campus
  Brenans Starbucks  On campus
  Cantina Del Cabo
  Carls Jr.  On campus
  Cenarios Pizza
  Center Court Café  On campus
  Ciocolat
  Cold Stone Creamery
  Dos Coyotes
  Dukes Sports Bar & Grill
  El Mariachi
  Natural Food Works Farmers Kitchen Café
  Freshens Smoothies  On campus
  Genome Center Cafe
  The Hotdogger
  House of Chang
  Med Sci Cafe  On campus
  Norms Pizza Norms Pizza & Gyros
  Papa Johns
  Pita Pit
  Pizza Hut Express  On campus
  The Posh Bagel
  Redrum Burger
  Silo 2
  Silo Pub and Cafe  On campus
  SubCity  On campus
  Subway
  Sudwerk
  Taco Bell Taco Bell Express  On campus
  Thai Recipes
  Wok n Roll
  Woodstocks Pizza