!Crown Copyright 2012 AWE.
!
! This file is part of CloverLeaf.
!
! CloverLeaf is free software: you can redistribute it and/or modify it under
! the terms of the GNU General Public License as published by the
! Free Software Foundation, either version 3 of the License, or (at your option)
! any later version.
!
! CloverLeaf 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 General Public License for more
! details.
!
! You should have received a copy of the GNU General Public License along with
! CloverLeaf. If not, see http://www.gnu.org/licenses/.

!>  @brief Fortran cell advection kernel.
!>  @author Wayne Gaudin
!>  @details Performs a second order advective remap using van-Leer limiting
!>  with directional splitting.

! Notes
! All the sweep numbers need to be update and intermediate volumes correctly calculated

MODULE advec_cell_kernel_module

CONTAINS

SUBROUTINE advec_cell_kernel(x_min,       &
                             x_max,       &
                             y_min,       &
                             y_max,       &
                             z_min,       &
                             z_max,       &
                             advect_x,    &
                             dir,         &
                             sweep_number,&
                             vertexdx,    &
                             vertexdy,    &
                             vertexdz,    &
                             volume,      &
                             density1,    &
                             energy1,     &
                             mass_flux_x, &
                             vol_flux_x,  &
                             mass_flux_y, &
                             vol_flux_y,  &
                             mass_flux_z, &
                             vol_flux_z,  &
                             pre_vol,     &
                             post_vol,    &
                             pre_mass,    &
                             post_mass,   &
                             advec_vol,   &
                             post_ener,   &
                             ener_flux    )

  IMPLICIT NONE

  INTEGER :: x_min,x_max,y_min,y_max,z_min,z_max
  INTEGER :: sweep_number,dir
  LOGICAL :: advect_x
  INTEGER :: g_xdir=1,g_ydir=2,g_zdir=3

  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+2) :: volume
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+2) :: density1
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+2) :: energy1
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+2,z_min-2:z_max+2) :: vol_flux_x
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+3,z_min-2:z_max+2) :: vol_flux_y
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+3) :: vol_flux_z
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+2,z_min-2:z_max+2) :: mass_flux_x
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+3,z_min-2:z_max+2) :: mass_flux_y
  REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2,z_min-2:z_max+3) :: mass_flux_z
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+3,z_min-2:z_max+3) :: pre_vol
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+3,z_min-2:z_max+3) :: post_vol
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+3,z_min-2:z_max+3) :: pre_mass
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+3,z_min-2:z_max+3) :: post_mass
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+3,z_min-2:z_max+3) :: advec_vol
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+3,z_min-2:z_max+2) :: post_ener
  REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+3,z_min-2:z_max+2) :: ener_flux

  REAL(KIND=8), DIMENSION(x_min-2:x_max+3) :: vertexdx
  REAL(KIND=8), DIMENSION(y_min-2:y_max+3) :: vertexdy
  REAL(KIND=8), DIMENSION(z_min-2:z_max+3) :: vertexdz

  INTEGER :: j,k,l,upwind,donor,downwind,dif

  REAL(KIND=8) :: wind,sigma,sigmat,sigmav,sigmam,sigma3,sigma4
  REAL(KIND=8) :: diffuw,diffdw,limiter
  REAL(KIND=8) :: one_by_six=1.0_8/6.0_8

!$OMP PARALLEL

  IF(dir.EQ.g_xdir) THEN

    IF(sweep_number.EQ.1)THEN
!$OMP DO
      DO l=z_min-2,z_max+2
        DO k=y_min-2,y_max+2
          DO j=x_min-2,x_max+2
            pre_vol(j,k,l)=volume(j,k,l)  +(vol_flux_x(j+1,k  ,l  )-vol_flux_x(j,k,l) &
                                           +vol_flux_y(j  ,k+1,l  )-vol_flux_y(j,k,l) &
                                           +vol_flux_z(j  ,k  ,l+1)-vol_flux_z(j,k,l))
            post_vol(j,k,l)=pre_vol(j,k,l)-(vol_flux_x(j+1,k  ,l  )-vol_flux_x(j,k,l))
          ENDDO
        ENDDO
      ENDDO
!$OMP END DO
    ELSEIF(sweep_number.EQ.3) THEN
!$OMP DO
      DO l=z_min-2,z_max+2
        DO k=y_min-2,y_max+2
          DO j=x_min-2,x_max+2
            pre_vol(j,k,l) =volume(j,k,l)+vol_flux_x(j+1,k  ,l  )-vol_flux_x(j,k,l)
            post_vol(j,k,l)=volume(j,k,l)
          ENDDO
        ENDDO
      ENDDO
!$OMP END DO
    ENDIF

!$OMP DO PRIVATE(upwind,donor,downwind,dif,sigmat,sigma3,sigma4,sigmav,sigma,sigmam, &
!$OMP            diffuw,diffdw,limiter)
    DO l=z_min,z_max
      DO k=y_min,y_max
        DO j=x_min,x_max+2

          IF(vol_flux_x(j,k,l).GT.0.0)THEN
            upwind   =j-2
            donor    =j-1
            downwind =j
            dif      =donor
          ELSE
            upwind   =MIN(j+1,x_max+2)
            donor    =j
            downwind =j-1
            dif      =upwind
          ENDIF

          sigmat=ABS(vol_flux_x(j,k,l))/pre_vol(donor,k,l)
          sigma3=(1.0_8+sigmat)*(vertexdx(j)/vertexdx(dif))
          sigma4=2.0_8-sigmat

          sigma=sigmat
          sigmav=sigmat

          diffuw=density1(donor,k,l)-density1(upwind,k,l)
          diffdw=density1(downwind,k,l)-density1(donor,k,l)
          IF(diffuw*diffdw.GT.0.0)THEN
            limiter=(1.0_8-sigmav)*SIGN(1.0_8,diffdw)*MIN(ABS(diffuw),ABS(diffdw)&
                ,one_by_six*(sigma3*ABS(diffuw)+sigma4*ABS(diffdw)))
          ELSE
            limiter=0.0
          ENDIF
          mass_flux_x(j,k,l)=vol_flux_x(j,k,l)*(density1(donor,k,l)+limiter)

          sigmam=ABS(mass_flux_x(j,k,l))/(density1(donor,k,l)*pre_vol(donor,k,l))
          diffuw=energy1(donor,k,l)-energy1(upwind,k,l)
          diffdw=energy1(downwind,k,l)-energy1(donor,k,l)
          IF(diffuw*diffdw.GT.0.0)THEN
            limiter=(1.0_8-sigmam)*SIGN(1.0_8,diffdw)*MIN(ABS(diffuw),ABS(diffdw)&
                ,one_by_six*(sigma3*ABS(diffuw)+sigma4*ABS(diffdw)))
          ELSE
            limiter=0.0
          ENDIF
          ener_flux(j,k,l)=mass_flux_x(j,k,l)*(energy1(donor,k,l)+limiter)

        ENDDO
      ENDDO
    ENDDO
!$OMP END DO

!$OMP DO
    DO l=z_min,z_max
      DO k=y_min,y_max
        DO j=x_min,x_max
          pre_mass(j,k,l)=density1(j,k,l)*pre_vol(j,k,l)
          post_mass(j,k,l)=pre_mass(j,k,l)+mass_flux_x(j,k,l)-mass_flux_x(j+1,k,l)
          post_ener(j,k,l)=(energy1(j,k,l)*pre_mass(j,k,l)+ener_flux(j,k,l)-ener_flux(j+1,k,l))/post_mass(j,k,l)
          advec_vol(j,k,l)=pre_vol(j,k,l)+vol_flux_x(j,k,l)-vol_flux_x(j+1,k,l)
          density1(j,k,l)=post_mass(j,k,l)/advec_vol(j,k,l)
          energy1(j,k,l)=post_ener(j,k,l)
        ENDDO
      ENDDO
    ENDDO
!$OMP END DO

  ELSEIF(dir.EQ.g_ydir) THEN
    IF(sweep_number.EQ.2) THEN
      IF(advect_x) THEN
!$OMP DO
        DO l=z_min-2,z_max+2
          DO k=y_min-2,y_max+2
            DO j=x_min-2,x_max+2
              pre_vol(j,k,l) =volume(j,k,l)  +vol_flux_y(j  ,k+1,l  )-vol_flux_y(j,k,l) &
                                             +vol_flux_z(j  ,k  ,l+1)-vol_flux_z(j,k,l)
              post_vol(j,k,l)=pre_vol(j,k,l)-(vol_flux_y(j  ,k+1,l  )-vol_flux_y(j,k,l))
            ENDDO
          ENDDO
        ENDDO
!$OMP END DO
      ELSE
!$OMP DO
        DO l=z_min-2,z_max+2
          DO k=y_min-2,y_max+2
            DO j=x_min-2,x_max+2
              pre_vol(j,k,l) =volume(j,k,l)  +vol_flux_y(j  ,k+1,l  )-vol_flux_y(j,k,l) &
                                             +vol_flux_x(j+1,k  ,l  )-vol_flux_x(j,k,l)
              post_vol(j,k,l)=pre_vol(j,k,l)-(vol_flux_y(j  ,k+1,l  )-vol_flux_y(j,k,l))
            ENDDO
          ENDDO
        ENDDO
!$OMP END DO
      ENDIF
    ENDIF

!$OMP DO PRIVATE(upwind,donor,downwind,dif,sigmat,sigma3,sigma4,sigmav,sigma,sigmam, &
!$OMP            diffuw,diffdw,limiter)
    DO l=z_min,z_max+2
      DO k=y_min,y_max+2
        DO j=x_min,x_max

          IF(vol_flux_y(j,k,l).GT.0.0)THEN
            upwind   =k-2
            donor    =k-1
            downwind =k
            dif      =donor
          ELSE
            upwind   =MIN(k+1,y_max+2)
            donor    =k
            downwind =k-1
            dif      =upwind
          ENDIF

          sigmat=ABS(vol_flux_y(j,k,l))/pre_vol(j,donor,l)
          sigma3=(1.0_8+sigmat)*(vertexdy(k)/vertexdy(dif))
          sigma4=2.0_8-sigmat

          sigma=sigmat
          sigmav=sigmat

          diffuw=density1(j,donor,l)-density1(j,upwind,l)
          diffdw=density1(j,downwind,l)-density1(j,donor,l)
          IF(diffuw*diffdw.GT.0.0)THEN
            limiter=(1.0_8-sigmav)*SIGN(1.0_8,diffdw)*MIN(ABS(diffuw),ABS(diffdw)&
                ,one_by_six*(sigma3*ABS(diffuw)+sigma4*ABS(diffdw)))
          ELSE
            limiter=0.0
          ENDIF
          mass_flux_y(j,k,l)=vol_flux_y(j,k,l)*(density1(j,donor,l)+limiter)

          sigmam=ABS(mass_flux_y(j,k,l))/(density1(j,donor,l)*pre_vol(j,donor,l))
          diffuw=energy1(j,donor,l)-energy1(j,upwind,l)
          diffdw=energy1(j,downwind,l)-energy1(j,donor,l)
          IF(diffuw*diffdw.GT.0.0)THEN
            limiter=(1.0_8-sigmam)*SIGN(1.0_8,diffdw)*MIN(ABS(diffuw),ABS(diffdw)&
                ,one_by_six*(sigma3*ABS(diffuw)+sigma4*ABS(diffdw)))
          ELSE
            limiter=0.0
          ENDIF
          ener_flux(j,k,l)=mass_flux_y(j,k,l)*(energy1(j,donor,l)+limiter)

        ENDDO
      ENDDO
    ENDDO
!$OMP END DO

!$OMP DO
    DO l=z_min,z_max
      DO k=y_min,y_max
        DO j=x_min,x_max
          pre_mass(j,k,l)=density1(j,k,l)*pre_vol(j,k,l)
          post_mass(j,k,l)=pre_mass(j,k,l)+mass_flux_y(j,k,l)-mass_flux_y(j,k+1,l)
          post_ener(j,k,l)=(energy1(j,k,l)*pre_mass(j,k,l)+ener_flux(j,k,l)-ener_flux(j,k+1,l))/post_mass(j,k,l)
          advec_vol(j,k,l)=pre_vol(j,k,l)+vol_flux_y(j,k,l)-vol_flux_y(j,k+1,l)
          density1(j,k,l)=post_mass(j,k,l)/advec_vol(j,k,l)
          energy1(j,k,l)=post_ener(j,k,l)
        ENDDO
      ENDDO
    ENDDO
!$OMP END DO

  ELSEIF(dir.EQ.g_zdir) THEN

    IF(sweep_number.EQ.1)THEN
!$OMP DO
      DO l=z_min-2,z_max+2
        DO k=y_min-2,y_max+2
          DO j=x_min-2,x_max+2
            pre_vol(j,k,l)=  volume(j,k,l)+(vol_flux_x(j+1,k  ,l  )-vol_flux_x(j,k,l) &
                                           +vol_flux_y(j  ,k+1,l  )-vol_flux_y(j,k,l) &
                                           +vol_flux_z(j  ,k  ,l+1)-vol_flux_z(j,k,l))
            post_vol(j,k,l)=pre_vol(j,k,l)-(vol_flux_z(j  ,k  ,l+1)-vol_flux_z(j,k,l))
          ENDDO
        ENDDO
      ENDDO
!$OMP END DO
    ELSEIF(sweep_number.EQ.3) THEN
!$OMP DO
      DO l=z_min-2,z_max+2
        DO k=y_min-2,y_max+2
          DO j=x_min-2,x_max+2
            pre_vol(j,k,l)= volume(j,k,l)+vol_flux_z(j  ,k,l+1)-vol_flux_z(j,k,l)
            post_vol(j,k,l)=volume(j,k,l)
          ENDDO
        ENDDO
      ENDDO
!$OMP END DO
    ENDIF

!$OMP DO PRIVATE(upwind,donor,downwind,dif,sigmat,sigma3,sigma4,sigmav,sigma,sigmam, &
!$OMP            diffuw,diffdw,limiter)
    DO l=z_min,z_max+2
      DO k=y_min,y_max
        DO j=x_min,x_max

          IF(vol_flux_z(j,k,l).GT.0.0)THEN
            upwind   =l-2
            donor    =l-1
            downwind =l
            dif      =donor
          ELSE
            upwind   =MIN(l+1,z_max+2)
            donor    =l
            downwind =l-1
            dif      =upwind
          ENDIF

          sigmat=ABS(vol_flux_z(j,k,l))/pre_vol(j,k,donor)
          sigma3=(1.0_8+sigmat)*(vertexdz(l)/vertexdz(dif))
          sigma4=2.0_8-sigmat

          sigma=sigmat
          sigmav=sigmat

          diffuw=density1(j,k,donor)-density1(j,k,upwind)
          diffdw=density1(j,k,downwind)-density1(j,k,donor)
          IF(diffuw*diffdw.GT.0.0)THEN
            limiter=(1.0_8-sigmav)*SIGN(1.0_8,diffdw)*MIN(ABS(diffuw),ABS(diffdw)&
                ,one_by_six*(sigma3*ABS(diffuw)+sigma4*ABS(diffdw)))
          ELSE
            limiter=0.0
          ENDIF
          mass_flux_z(j,k,l)=vol_flux_z(j,k,l)*(density1(j,k,donor)+limiter)

          sigmam=ABS(mass_flux_z(j,k,l))/(density1(j,k,donor)*pre_vol(j,k,donor))
          diffuw=energy1(j,k,donor)-energy1(j,k,upwind)
          diffdw=energy1(j,k,downwind)-energy1(j,k,donor)
          IF(diffuw*diffdw.GT.0.0)THEN
            limiter=(1.0_8-sigmam)*SIGN(1.0_8,diffdw)*MIN(ABS(diffuw),ABS(diffdw)&
                ,one_by_six*(sigma3*ABS(diffuw)+sigma4*ABS(diffdw)))
          ELSE
            limiter=0.0
          ENDIF
          ener_flux(j,k,l)=mass_flux_z(j,k,l)*(energy1(j,k,donor)+limiter)

        ENDDO
      ENDDO
    ENDDO
!$OMP END DO

!$OMP DO
    DO l=z_min,z_max
      DO k=y_min,y_max
        DO j=x_min,x_max
          pre_mass(j,k,l)=density1(j,k,l)*pre_vol(j,k,l)
          post_mass(j,k,l)=pre_mass(j,k,l)+mass_flux_z(j,k,l)-mass_flux_z(j,k,l+1)
          post_ener(j,k,l)=(energy1(j,k,l)*pre_mass(j,k,l)+ener_flux(j,k,l)-ener_flux(j,k,l+1))/post_mass(j,k,l)
          advec_vol(j,k,l)=pre_vol(j,k,l)+vol_flux_z(j,k,l)-vol_flux_z(j,k,l+1)
          density1(j,k,l)=post_mass(j,k,l)/advec_vol(j,k,l)
          energy1(j,k,l)=post_ener(j,k,l)
        ENDDO
      ENDDO
    ENDDO
!$OMP END DO

  ENDIF

!$OMP END PARALLEL

END SUBROUTINE advec_cell_kernel

END MODULE advec_cell_kernel_module


text:
c
c ---------------------------------------------------
c
       subroutine coarsen(valdub,midub,mjdub,valbgc,mi2tot,mj2tot,nvar)

       implicit double precision (a-h, o-z)

       dimension  valdub(nvar,midub, mjdub)
       dimension  valbgc(nvar,mi2tot,mj2tot)

c :::::::::::::::::::::::: COARSEN ::::::::::::::::::::::::::::::::
c coarsen = coarsen the fine grid data (with double the usual
c           number of ghost cells to prepare coarsened
c           grid for error estimation.
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

       do 10 j = 1, mj2tot

          jfine = 2*(j-1) + 1

          do 10 i = 1, mi2tot
            ifine = 2*(i-1) + 1

            do 10 ivar = 1, nvar

             valbgc(ivar,i,j) = (valdub(ivar,ifine,jfine) +
     &                           valdub(ivar,ifine+1,jfine)+
     &                           valdub(ivar,ifine,jfine+1) +
     &                           valdub(ivar,ifine+1,jfine+1))/4.d0
10     continue

       return
       end

ext: f

max_stars_repo_name: ian-r-rose/visualization

max_issues_repo_name: ian-r-rose/visualization

max_forks_repo_name: ian-r-rose/visualization


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 04.02.03.02/10                        *
C  *    TEST TITLE : Appearance of predefined text         *
C  *                 bundles                               *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

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

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

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

C aspect source
C                bundled     individual
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)

C text precision
      INTEGER    PSTRP,     PCHARP,     PSTRKP
      PARAMETER (PSTRP = 0, PCHARP = 1, PSTRKP = 2)

C colour model
      INTEGER    PRGB,     PCIE,     PHSV,     PHLS
      PARAMETER (PRGB = 1, PCIE = 2, PHSV = 3, PHLS = 4)

C text alignment horizontal
      INTEGER    PAHNOR,     PALEFT,     PACENT,     PARITE
      PARAMETER (PAHNOR = 0, PALEFT = 1, PACENT = 2, PARITE = 3)

C text alignment vertical
      INTEGER    PAVNOR,     PATOP,      PACAP,     PAHALF,
     1           PABASE,     PABOTT
      PARAMETER (PAVNOR = 0, PATOP  = 1, PACAP = 2, PAHALF = 3,
     1           PABASE = 4, PABOTT = 5)

      INTEGER   PICSTR, TXCI, IX, CLEN
      INTEGER   NPREI, NUMBUN, BUNDIS(8), BUNDIF, PDFN, PDPR, PDCI
      INTEGER   RNDINT, IARFND
      INTEGER   IDUM1, IDUM2, IDUM3, IDUM4, IDUM5
      REAL      RDUM1, RDUM2, RDUM3, RDUM4

      REAL      YLOC, YINCR, YBOT,YTOP, PDEX, PDSP

      LOGICAL   DYN

      CHARACTER LNTID*40, PRECNM(PSTRP:PSTRKP)*6

      DATA PRECNM / 'STRING', 'CHAR', 'STROKE' /

      CALL INITGL ('04.02.03.02/10')

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

      CALL POPST (PICSTR)
C  by convention, view #1 is for picture
      CALL PSVWI (1)
C  use bundled attributes
      CALL SETASF (PBUNDL)

C  nprei = number of predefined text bundles
      CALL PQTXF (SPECWT, 0, ERRIND, IDUM1, IDUM2, IDUM3, IDUM4,
     1           RDUM1, RDUM2, IDUM5, RDUM3, RDUM4, NPREI)
      CALL CHKINQ ('pqtxf', ERRIND)

C *** *** *** *** predefined text bundles 1-6

C  mark start of text bundles 1-6
      CALL PLB (1)

C  use first 6 indices + 1 duplicate
      NUMBUN = 7
      CALL RNPERM (7, BUNDIS)
C  location of #7
      BUNDIF = IARFND(7, 7, BUNDIS)
      BUNDIS(BUNDIF) = RNDINT(1,6)

      CALL SETMSG ('3 6 20 24', 'Immediately after <open '           //
     1             'workstation>, the first 6 defined text bundles ' //
     2             'of the WSL should appear as specified in the '   //
     3             'corresponding predefined text bundles of the WDT.')

      CALL DRWTXT (NUMBUN, BUNDIS, BUNDIF)
C  mark end of bundles 1-6
      CALL PLB (2)

      CALL DCHPFV ('WORKSTATION DESCRIPTION AND STATE LIST TABLES, '  //
     1             'INDICES 1-6: Which pair of text primitives does ' //
     2             'NOT match?', NUMBUN, BUNDIF)

C  clear out last display from structure
      CALL PSEP (1)
      CALL PDELLB (1,2)

C *** *** *** *** predefined text bundles > 6

C  skip if there are only 6 bundles
      IF (NPREI .LE. 6) THEN
         CALL INMSG ('Skip test of bundles > 6, only 6 predefined ' //
     1               'bundles supported.')
         GOTO 500
      ENDIF

C  numbun = number of bundles beyond #6 to be displayed
      NUMBUN = MIN (8, NPREI-6)
C  select bundles (as distinct as possible) from list of
C    predefined bundles [7, nprei]
      CALL DISTXB (NUMBUN, 7, NPREI, BUNDIS)

      CALL SETMSG ('3 6 20 24', 'Immediately after <open '          //
     1             'workstation>, the defined text bundles > 6 of ' //
     2             'the WSL should appear as specified in the '     //
     3             'corresponding predefined text bundles of the WDT.')

C  bundif = randomly selected bundle to be shown incorrectly
      BUNDIF = RNDINT(1, NUMBUN)
      CALL DRWTXT (NUMBUN, BUNDIS, BUNDIF)

      CALL DCHPFV ('WORKSTATION DESCRIPTION AND STATE LIST TABLES, '  //
     1             'INDICES > 6: Which pair of text primitives does ' //
     2             'NOT match?', NUMBUN, BUNDIF)

C  clear out last display from structure
      CALL PSEP (1)
      CALL PDELLB (1,2)

C  end_comp_tables
500   CONTINUE

C *** *** *** ***  predefined bundle descriptions

      CALL SETMSG ('3 6 20', 'The appearance of predefined ' //
     1             'text bundles should agree with the '     //
     2             'descriptions supplied by the implementor.')

      NUMBUN = MIN (8, NPREI)
C  bundis = distinct bundles to be displayed, chosen from [1,nprei]
      CALL DISTXB (NUMBUN, 1, NPREI, BUNDIS)
      CALL SRTIAR (NUMBUN, BUNDIS)

C  set all ASFs to BUNDLED
      CALL SETASF (PBUNDL)
      YLOC = 0.8
      YINCR = 0.1
      CALL PSCHH (0.03)
      CALL PSTXAL (PALEFT, PAHALF)
      DO 550 IX = 1, NUMBUN
         CALL PSTXI (BUNDIS(IX))
         CALL PTX (0.2, YLOC, 'Phigs')
         YLOC = YLOC - YINCR
550   CONTINUE

C  set all ASFs to INDIVIDUAL
      CALL SETASF (PINDIV)

C  set label
      YLOC  = 0.9
      YBOT = YLOC-0.3*YINCR
      YTOP = YLOC+0.3*YINCR
      CALL VISLAB ('Bundle#',   'R', 0.02, 0.15, YBOT,YTOP)
      CALL VISLAB ('     Font', 'R', 0.40, 0.50, YBOT,YTOP)
      CALL VISLAB ('Precision', 'R', 0.53, 0.63, YBOT,YTOP)
      CALL VISLAB ('Expansion', 'R', 0.66, 0.76, YBOT,YTOP)
      CALL VISLAB ('  Spacing', 'R', 0.76, 0.86, YBOT,YTOP)
      CALL VISLAB ('    Color', 'R', 0.86, 0.96, YBOT,YTOP)

C  display and label values for pdfn, pdpr, pdex, pdsp, pdci
      DO 600 IX = 1, NUMBUN
         YLOC = YLOC - YINCR
         CALL PQPTXR (SPECWT, BUNDIS(IX), ERRIND, PDFN, PDPR, PDEX,
     1                PDSP, PDCI)
         CALL CHKINQ ('pqptxr', ERRIND)

         YBOT = YLOC-0.3*YINCR
         YTOP = YLOC+0.3*YINCR

         WRITE (LNTID, '(I5,A)') BUNDIS(IX), ': '
         CALL VISLAB (LNTID(1:7), 'R', 0.02, 0.15, YBOT,YTOP)
         WRITE (LNTID, '(I5)') PDFN
         CALL VISLAB (LNTID(1:5), 'R', 0.40, 0.50, YBOT,YTOP)

         IF (PDPR.GE.PSTRP .AND. PDPR.LE.PSTRKP) THEN
            LNTID = ' ' // PRECNM(PDPR)
            CLEN = 7
         ELSE
            WRITE (LNTID, '(I5)') PDPR
            CLEN = 5
         ENDIF
         CALL VISLAB (LNTID(1:CLEN), 'R', 0.53, 0.63, YBOT,YTOP)

         WRITE (LNTID, '(F7.3)') PDEX
         CALL VISLAB (LNTID(1:7), 'R', 0.66, 0.76, YBOT,YTOP)
         WRITE (LNTID, '(F7.3)') PDSP
         CALL VISLAB (LNTID(1:7), 'R', 0.76, 0.86, YBOT,YTOP)
         WRITE (LNTID, '(I5)') PDCI
         CALL VISLAB (LNTID(1:5), 'R', 0.86, 0.96, YBOT,YTOP)

600   CONTINUE

      IF (DYN('PREDEFINED TEXT BUNDLES: Does the appearance of ' //
     1        'each text primitive agree with the displayed '    //
     2        'aspect values for that bundle?')) THEN
         CALL DYNPF ('PREDEFINED TEXT BUNDLES: If the implementor ' //
     1               'provides external documentation, is it '      //
     2               'consistent with the text appearance and '     //
     3               'displayed aspect values for every bundle '    //
     4               'identifier?', 'Y')
      ELSE
         CALL OPFAIL
      ENDIF

666   CONTINUE
C  wrap it up
      CALL ENDIT
      END


text:
#! Demonstrates the usage of parameterized test fixtures.

#:include 'fytest.fypp'

#:block TEST_SUITE('parameterized')
  use mymath
  implicit none

#:contains

  #! We use the test suite initializer to initialize the seed
  #! Note: This routine is called once before any tests are executed.
  #:block TEST_SUITE_INIT
    call random_seed()
  #:endblock

  #! Parameterized test, iterator runs over the range from 1 to 10.

  #:block TEST_FIXTURE('random', ITERATORS=[('iter', 10)], RENDERER='render')

    #! Iterator variables must be declared in the fixture scope
    integer :: iter

    #! Some other fixture variable
    integer :: curval

  #:contains

    #! Test fixture initializer is called each time before a test starts.
    #! A separate scope is created for each test.
    #:block TEST_FIXTURE_INIT
      real :: rand

      call random_number(rand)
      curval = int(rand * 10.0) + 1
    #:endblock

    #! Tests can access the fixture scope

    #:block TEST('recursion_up')
      @:ASSERT(factorial(curval) * (curval + 1) == factorial(curval + 1))
    #:endblock

    #:block TEST('recursion_down')
      @:ASSERT(factorial(curval) == curval * factorial(curval - 1))
    #:endblock

    #! We define a renderer to show the random number used in a given fixture
    #! A renderer must have no arguments and return a string containing a human
    #! readable representation of the fixture.
    function render() result(str)
      character(:), allocatable :: str

      character(10) :: buffer

      write(buffer, "(A,I0)") 'curval=', curval
      str = trim(buffer)

    end function render

  #:endblock TEST_FIXTURE

#:endblock TEST_SUITE

#:block TEST_DRIVER()
#:endblock TEST_DRIVER

ext: fpp

max_stars_repo_name: aradi/fytest

max_issues_repo_name: aradi/fyunit

max_forks_repo_name: aradi/fyunit


! { dg-do run }
! PR fortran/78350
program p
   type t
      character(2) :: c(1) = [character(3) :: 'abc']
   end type
   type(t) :: x
   if (trim(x%c(1)) /= 'ab') call abort
end


text:
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!   Copyright by The HDF Group.                                               *
!   Copyright by the Board of Trustees of the University of Illinois.         *
!   All rights reserved.                                                      *
!                                                                             *
!   This file is part of HDF5.  The full HDF5 copyright notice, including     *
!   terms governing use, modification, and redistribution, is contained in    *
!   the files COPYING and Copyright.html.  COPYING can be found at the root   *
!   of the source code distribution tree; Copyright.html can be found at the  *
!   root level of an installed copy of the electronic HDF5 document set and   *
!   is linked from the top-level documents page.  It can also be found at     *
!   http://hdfgroup.org/HDF5/doc/Copyright.html.  If you do not have          *
!   access to either file, you may request a copy from help@hdfgroup.org.     *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
! In this example we iterate through the members of the groups.
!

     PROGRAM GRPITEXAMPLE

     USE HDF5 ! This module contains all necessary modules

     IMPLICIT NONE

     CHARACTER(LEN=11), PARAMETER :: filename = "iteratef.h5" ! File name
     CHARACTER(LEN=7), PARAMETER :: groupname1 = "MyGroup"    ! Group name
     CHARACTER(LEN=15), PARAMETER :: groupname2 = "Group_A"   ! Group name
     CHARACTER(LEN=13), PARAMETER :: dsetname1 = "dset1"      ! Dataset name
     CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2"       !

     CHARACTER(LEN=20) :: name_buffer ! Buffer to hold object's name
     INTEGER :: type ! Type of the object
     INTEGER :: nmembers ! Number of group members

     INTEGER(HID_T) :: file_id        ! File identifier
     INTEGER(HID_T) :: dataset1_id    ! Dataset1 identifier
     INTEGER(HID_T) :: dataset2_id    ! Dataset2 identifier
     INTEGER(HID_T) :: dataspace1_id  ! Data space identifier
     INTEGER(HID_T) :: dataspace2_id  ! Data space identifier
     INTEGER(HID_T) :: group1_id, group2_id ! Group identifiers

     INTEGER     ::  i, j

     INTEGER     ::   error ! Error flag

     INTEGER, DIMENSION(3,3) :: dset1_data  ! Arrays to hold data
     INTEGER, DIMENSION(2,10) :: dset2_data !

     INTEGER(HSIZE_T), DIMENSION(2) :: dims1 = (/3,3/) ! Dataset dimensions
     INTEGER(HSIZE_T), DIMENSION(2) :: dims2 = (/2,10/)!
     INTEGER     ::   rank = 2 ! Datasets rank
     INTEGER(HSIZE_T), DIMENSION(2) :: data_dims

     !
     ! Initialize dset1_data array.
     !
     do i = 1, 3
          do j = 1, 3
               dset1_data(i,j) = j;
          end do
     end do

     !
     ! Initialize dset2_data array.
     !
     do i = 1, 2
          do j = 1, 10
               dset2_data(i,j) = j;
          end do
     end do

     !
     ! Initialize FORTRAN interface.
     !
     CALL h5open_f(error)

     !
     ! Create a new file using default properties.
     !
     CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error)

     !
     ! Create group "MyGroup" in the root group using absolute name.
     !
     CALL h5gcreate_f(file_id, groupname1, group1_id, error)

     !
     ! Create group "Group_A" in group "MyGroup" using relative name.
     !
     CALL h5gcreate_f(group1_id, groupname2, group2_id, error)

     !
     ! Create the data space for the first dataset.
     !
     CALL h5screate_simple_f(rank, dims1, dataspace1_id, error)

     !
     ! Create a dataset in group "MyGroup" with default properties.
     !
     CALL h5dcreate_f(group1_id, dsetname1, H5T_NATIVE_INTEGER, dataspace1_id, &
                      dataset1_id, error)

     !
     ! Write the first dataset.
     !
     data_dims(1) = 3
     data_dims(2) = 3
     CALL h5dwrite_f(dataset1_id, H5T_NATIVE_INTEGER, dset1_data, data_dims, error)

     !
     ! Create the data space for the second dataset.
     !
     CALL h5screate_simple_f(rank, dims2, dataspace2_id, error)

     !
     ! Create the second dataset in group "Group_A" with default properties
     !
     CALL h5dcreate_f(group2_id, dsetname2, H5T_NATIVE_INTEGER, dataspace2_id, &
                     dataset2_id, error)

     !
     ! Write the second dataset
     !
     data_dims(1) = 2
     data_dims(2) = 10
     CALL h5dwrite_f(dataset2_id, H5T_NATIVE_INTEGER, dset2_data, data_dims, error)

     !
     ! Get number of members in the root group.
     !
     CALL h5gn_members_f(file_id, "/", nmembers, error)
     write(*,*) "Number of root group member is " , nmembers

     !
     ! Print each group member's name and type.
     !
     do i = 0, nmembers - 1
        CALL h5gget_obj_info_idx_f(file_id, "/", i, name_buffer, type, &
                                    error)
     write(*,*) name_buffer, type
     end do

     !
     ! Get number of members in MyGroup.
     !
     CALL h5gn_members_f(file_id, "MyGroup", nmembers, error)
     write(*,*) "Number of group MyGroup member  is ", nmembers

     !
     ! Print each group member's name and type in "MyGroup" group.
     !
     do i = 0, nmembers - 1
        CALL h5gget_obj_info_idx_f(file_id, groupname1, i, name_buffer, type, &
                                    error)
     write(*,*) name_buffer, type
     end do

     !
     ! Get number of members in MyGroup/Group_A.
     !
     CALL h5gn_members_f(file_id, "MyGroup/Group_A", nmembers, error)
     write(*,*) "Number of group MyGroup/Group_A member  is ", nmembers

     !
     ! Print each group member's name and type in "MyGroup/Group_A" group.
     !
     do i = 0, nmembers - 1
        CALL h5gget_obj_info_idx_f(file_id,"MyGroup/Group_A" , i, name_buffer, type, &
                                    error)
     write(*,*) name_buffer, type
     end do

     !
     ! Close the dataspace for the first dataset.
     !
     CALL h5sclose_f(dataspace1_id, error)

     !
     ! Close the first dataset.
     !
     CALL h5dclose_f(dataset1_id, error)

     !
     ! Close the dataspace for the second dataset.
     !
     CALL h5sclose_f(dataspace2_id, error)

     !
     ! Close the second dataset.
     !
     CALL h5dclose_f(dataset2_id, error)

     !
     ! Close the groups.
     !
     CALL h5gclose_f(group1_id, error)

     CALL h5gclose_f(group2_id, error)

     !
     ! Close the file.
     !
     CALL h5fclose_f(file_id, error)

     !
     ! Close FORTRAN interface.
     !
     CALL h5close_f(error)

     END PROGRAM GRPITEXAMPLE

max_stars_repo_name: pbasting/cactus

max_issues_repo_name: pbasting/cactus

max_forks_repo_name: pbasting/cactus


text:
Describe Blackmon & Associates Historical here.

req memory hole
 At this point Im asking that nothing further be memory holed, or if it is, that records be kept of both the info page and the text before it is memory holed.  It has progressed beyond the wiki, including a phone call to my former employer and postings on many different websites.  I would like to keep a record of everything. Users/TomGarberson

      No memory holing...
Under the lack of SOPA bill everything is permitted!
http://en.m.wikipedia.org/wiki/Stop_Online_Piracy_Act
Its a dangerous and troubling development when the platforms that serve as gateways to information intentionally skew the facts to incite their users and arm them with misinformation, and its very difficult to counter the misinformation when the disseminators also own the platform.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
! chk_opentwice.f90 --
!     Check: does the compiler support opening the same file on two different units?
!
!     Note: this is an extension to the standard
!
program chk_opentwice
    implicit none

    integer :: i, ierr
    integer :: value1
    integer :: value2
    integer :: lun1 = 10
    integer :: lun2 = 20
    logical :: opened

    !
    ! First create a file that we can read
    !
    open( lun1, file = 'chk_opentwice.inp' )
    write( lun1, '(i0)' ) (i ,i=1,10)
    close( lun1 )

    !
    ! Now open it on lun1 and read the third number
    !
    open( lun1, file = 'chk_opentwice.inp' )
    read( lun1, * ) (value1 , i=1,3)

    !
    ! Now open it again on lun2 and read a single value
    !
    open( lun2, file = 'chk_opentwice.inp', iostat = ierr )

    if ( ierr /= 0 ) then
        write( *, '(a)' ) 'Error opening the file again - extension not supported'
        stop
    endif

    !
    ! If all went well, try reading via both LU-numbers
    !
    read( lun2, * ) value2

    read( lun1, *, iostat = ierr ) value1 ! Expecting the value 4, if the extension is supported

    !
    ! Is the file still open on lun1?
    !
    inquire( lun1, opened = opened )

    if ( opened ) then
        write( *, '(a)'    ) 'File could be opened independently on a second unit'
        write( *, '(a,i0)' ) '    Value from the second unit: ', value2
        if ( value2 == 1 ) then
            write( *, '(a,i0)' ) '    Value is 1, as expected'
        else
            write( *, '(a,i0)' ) '    BUT: value should have been 1!'
        endif
        if ( ierr /= 0 ) then
            write( *, '(a,i0)' ) '    BUT: reading the file on the first unit gave an error!'
        elseif ( value1 /= 4 ) then
            write( *, '(a,i0)' ) '    BUT: reading the file on the first unit gave an unexpected value!'
            write( *, '(a,i0)' ) '         value read:       ', value1
            write( *, '(a,i0)' ) '         should have been: ', 4
        else
            write( *, '(a,i0)' ) '    Value from the first unit: ', value1
            write( *, '(a,i0)' ) '    Value is 4, as expected'
            write( *, '(a)'    ) 'The extension is supported'
        endif
    else
        write( *, '(a)'    ) 'File can NOT be opened independently on a second unit'
    endif
end program chk_opentwice

max_stars_repo_name: philip-peterson/flibs

max_issues_repo_name: philip-peterson/flibs

max_forks_repo_name: philip-peterson/flibs


text:
+incdir+../../rtl
+define+FRISCV_SIM
./scram.sv
../../rtl/friscv_rv32i_control.sv
../../rtl/friscv_rv32i_decoder.sv
../../rtl/friscv_rv32i_alu.sv
../../rtl/friscv_csr.sv
../../rtl/friscv_rv32i_memfy.sv
../../rtl/friscv_registers.sv
../../rtl/friscv_scfifo.sv
../../rtl/friscv_scfifo_ram.sv
../../rtl/friscv_apb_interconnect.sv
../../rtl/friscv_gpios.sv
../../rtl/friscv_uart.sv
../../rtl/friscv_user_interfaces.sv

max_stars_repo_name: mfkiwl/friscv

max_issues_repo_name: mfkiwl/friscv

max_forks_repo_name: mfkiwl/friscv


text:
      subroutine stfset(s,nel,model,beta,nels)
c     implicit double precision (a-h,o-z)                                    dp
       use mod_parameters
      common/bk00/
     1k01,k02,k03,k04,k05,k06,k07,k08,k09,k10,k11,k12,
     2k13,k14,k15,k16,k17,k18,k19,k20,k21,k22,k23,k24,
     3k25,k26,k27,k28,k29,k30,k31,k32,k33,k34,k35,k36,
     4k37,k38,k39,k40,k41,k42,k43,k44,k45,k46,k47,k48,
     5k49,k50,k51,k52,k53,k54,k55,k56,k57,k58,k59,k60,
     6k61,k62,k63,k64,k65,k66,k67,k68,k69,k70,k71,k72,
     7k73,k74,k75,k76,k77,k78,k79,k80,k81,k82,k83,k84,
     8k85,k86,k87,k88,k89,k90,k91,k92,k93,k94,k95,k96
      common/bk02/ioofc,iphase,imass,lpar(9)
      common/bk16/maxint,hgc
      common/vect1/r(nelemg,10)
      common/vect7/
     1 diavg(nelemg),dfavg(nelemg),volnd(nelemg),volcd(nelemg),
     > vlinc(nelemg),volgp(nelemg),
     2 dimod(nelemg),sig11(nelemg),sig22(nelemg),sig33(nelemg),
     > sig12(nelemg)
      common/main_block/ a(1)
      dimension s(*)

!        write(7777,*) '-- stfset.f'

      do 10 i=1,36
   10 s(i)=0.

      do 20 i=1,8
   20 r(nels,i)=0.0
      s(1) =0.0001
      s(3) =0.0001
      s(6) =0.0001
      s(10)=0.0001
      s(15)=0.0001
      s(21)=0.0001
      s(28)=0.0001
      s(36)=0.0001
c
c     zero stress
c
      ln=maxint*lpar(9)
      ii=k14+ln*(nel-1)
      j=4
      if (model.eq.3) j=8
      if (model.eq.5) j=8
      if (model.eq.6) j=8
      if (model.eq.21)j=8
      do 40 ipt=1,maxint
      if (model.eq.4) nn=ii+8+(ipt-1)*(lpar(9)-2)
      if (model.ne.4) nn=ii+lpar(9)*(ipt-1)
      do 30 i=1,j
   30 a(nn+i-1)=0.
      if (model.eq.4) a(nn+5)=0.
      if (model.eq.5) beta=1./dfavg(nels)
      if (model.eq.21)beta=1./dfavg(nels)
   40 continue
      return
      end

max_stars_repo_name: imohame/LabCode

max_issues_repo_name: imohame/LabCode

max_forks_repo_name: imohame/LabCode


text:
Davis is home to both Girl Scouts and Boy Scouts (including Cub Scouts).

Scouts in either of these groups (nationally, the wiki:WikiPedia:Girl_Scouts_of_the_USA Girl Scouts of the USA and wiki:WikiPedia:Boy_Scouts_of_America Boy Scouts of America) learn skills that are connected to activities like outdoor survival measures, camping techniques and first aid while developing basic skills such as leadership, communication and discipline that will help them in later life.

Boy Scouts tend to do more outdoor activities than Girl Scouts, but both groups can be fun. The Scouting Movement was originally started in the United Kingdom by wiki:WikiPedia:Lord BadenPowell Lord Robert BadenPowell, who wrote a book called wiki:WikiPedia:Scouting for Boys, an adaptation of manuals used by the British Army to train scouts.  They first came to national attention in the United States during the First World War while organizing a campaign to conserve food and other products for the war effort.  Scouting arrived in Davis in 1920 with the Boy Scouts Boy Scouts of America.

There are many forms of Boy Scouts, some paths that a Scout can take upon earning a certain rank and others that they choose when joining.  Some of these Scout forms are tightly associated with other groups, such as police or forest rangers.  There are also versions for children under the age of Boy Scouts: Cub Scouts, Webelos Scouts and Tiger Scouts.  Cub Scouts are international and based on the universe of Kiplings The Jungle Book.

Certain forms of American Boy Scout troops only accept boys, while others accept both sexes.  Girl Scouts and Brownies are a different organization that accept only girls.  Girl Scouts of the USA is not part of the World Organization of the Scout Movement; instead, they are linked to the World Association of Girl Guides and Girl Scouts.  At the local level, the two groups often work together.

The quality of a troop, be it Boy Scouts or Girl Scouts, depends greatly on the work of the adult leaders. Scouting is a lot of work for adults who are pressed for time. The rewards can be great though.

Just how inclusive is scouting in Davis?  Issues surrounding who is allowed to participate in Daviss scouting programs  gays? atheists? as scouts or as troop leaders?  have led to Davisites Davisite discussions of scouting controversies.

Links
  http://www.scouting.org/ Boy Scouts of America official homepage.
  http://www.girlscouts.org/ Girl Scouts of the USA official homepage.

20061220 14:29:31 nbsp The article mentions adult leaders but it seems to me the most important leadership comes from the scouts themselves. KevinRollins

20130321 12:37:32 nbsp It would be awesome if some parents could start a Camp Fire group. They are coed and inclusive. Users/NoelBruening
   I think you will find that if you reach out to the local units, they are also inclusive.  BSA also has coed programs, including Venturing Crew 66 here in Davis.   Users/DavidGrundler
    This comment spawned a discussion on scouting controversies inclusiveness in our local scouting programs.

20130430 13:46:35 nbsp Venture is for teens (my son is 6). But thanks for the info. Users/NoelBruening


! { dg-do run }
!
! Run-time test for EVENT_TYPE
!
use iso_fortran_env, only: event_type
implicit none

type(event_type), save :: var[*]
integer :: count, stat

count = -42
call event_query (var, count)
if (count /= 0) STOP 1

stat = 99
event post (var, stat=stat)
if (stat /= 0) STOP 2
call event_query(var, count, stat=stat)
if (count /= 1 .or. stat /= 0) STOP 3

stat = 99
event post (var[this_image()])
call event_query(var, count)
if (count /= 2) STOP 4

stat = 99
event wait (var)
call event_query(var, count)
if (count /= 1) STOP 5

stat = 99
event post (var)
call event_query(var, count)
if (count /= 2) STOP 6

stat = 99
event post (var)
call event_query(var, count)
if (count /= 3) STOP 7

stat = 99
event wait (var, until_count=2)
call event_query(var, count)
if (count /= 1) STOP 8

stat = 99
event wait (var, stat=stat, until_count=1)
if (stat /= 0) STOP 9
call event_query(event=var, stat=stat, count=count)
if (count /= 0 .or. stat /= 0) STOP 10
end


text:
The Winter 2010 ASUCD Election was the ASUCD Presidential and Senatorial ASUCD Elections election that took place Wednesday, February 17th to Friday, February 19th.  Six of the twelve ASUCD Senate seats were contested at this election.  ASUCD President Presidentelect Jack Zwald and ASUCD Vice President Vice Presidentelect Previn Witana were elected as a ticket pursuant to Article III, Section 3 of the ASUCD Constitution.

The results of the election were announced Friday, February 19th at 12:00pm by the MU flagpole. The election could be challenged because the Elections Committee illegally put Subhan Cheema, Sergio Blanco, and Vishakha Patel on the ballot when they didnt submit enough signatures in time (see http://daviswiki.org/Winter_2010_ASUCD_Election#head18426ef12203050e6b0cfb30ebc454bb7c45f616 controversy). However, since eliminating these candidates from the running doesnt change the results, such a challenge is unlikely.

Results
Winners
Executive
  Jack Zwald, president
  Previn Witana, vice president

Senate
  Adam Thongsavat
  Alison Tanner
  Liz Walz
  Osahon Ekhator
  Ozzy Arce
  Selisa Romero

Vote distribution
Executive

Zwald/Witana beat Blanco/Patel 1,678 to 1,561 after Webb/Martín was eliminated, 51.8% to 48.2% (3.6% margin of victory).

Senate
Table is in order of election or elimination.
Summary of Senate Voting
No candidate reached the required 519 vote quota to be elected in the first round.  First round elections have only happened in 5 of the 14 ASUCD Senate elections using Choice Voting.

Adam Thongsavat was elected after Christopher Adams was eliminated.  Cheema, Senesi, Stone, Ornelas, and Turkell were eliminated in subsequent rounds, resulting in Liz Walz and Ozzy Arce being elected in the eighth round.

Raj Kumar was the final candidate eliminated, resulting in the remaining three candidates being elected automatically. However, Alison Tanner did reach the threshold in the eleventh round.  Osahon Ekhator reached the threshold with Alison Tanners surplus votes.  Selisa Romero was elected about 35 votes short of the threshold (which is irrelevant once there are no more candidates to eliminate).  http://jtleathers.0sites.net/asucd/2010_Winter/winter2010overview.html Ballot data analysis shows, if Kumar had received 19 more votes in the final round of the election, he would have been elected instead of Selisa Romero.

The new Senate will have 6 LEAD Senators (no change), 4 JAM (+2), and 2 Independents (1).  Justin Golds expired term renders the ACT slate extinct.

Christopher Adams joins the Users/RevChad Rev. Chad Van Schoelandt as a consecutive winner of the Most Hated Person on Campus title, the first repeater in five years.

If youre wondering how the election would have turned out under different election rules, visit Winter 2010 ASUCD Election/Bizarro World Bizarro World.

President Race
The terms of Independent independent President Joe Chatham and Vice President Chris Dietrich expire at the start of the last ASUCD Senate Senate meeting of Winter Quarter 2010.  Pursuant to Article III, Section 3 of the ASUCD Constitution, they are expected to deliver Certificates of Election to LEAD slate Presidentelect Jack Zwald and Vice Presidentelect Previn Witana at the beginning of the final ASUCD Senate Senate meeting of their terms, projected to be March 11, 2010, whereupon Zwald and Witana will immediately assume office.

Candidates on the Ballot
Independent Independent
  Internal Affairs Commission Alternate Greg Webb ran for President with Outreach Assemblymember Jessica Martín as his running mate.
    Read about their campaign Greg Webb/Winter 2010 Election here on DavisWiki or at http://www.votewebbmartin.info
LEAD slate
  Former ASUCD Senator Jack Zwald and current Senator Previn Witana were the Presidential and Vice Presidential candidates for LEAD, respectively.
JAM slate
  Former ASUCD Senator Sergio Blanco ran for President with Vishakha Patel as his running mate.
Controversy  Blanco/Patel eligibility
Daniel Golden filed wiki:court:Case 48: Golden v ASUCD Elections Committee an ASUCD Court case against the Elections Committee alleging that because their petition to run for executive office lacked sufficient valid signatures/SIDs by the deadline, they should not be placed on the ballot.  The Elections Committee allowed the ticket to appear on the ballot after granting the ticket time to gather sufficient signatures to make up the deficit, a policy they made available to all candidates.  wiki:court:Ryan Meyerhoff Justice Ryan Meyerhoff recused himself as Golden is his housemate.  The case was heard February 10th 6:15pm and the Court, in a 42 majority decision, held that the Elections Committee exceeded its authority, and ordered the Elections Committee not to place Blanco and Patel on the executive ballot.

In a decision sure to cause PoliSci and History majors to misquote Andrew Jackson, Elections Committee Chair Nick Sidney released a statement on Tuesday, February 16, one day before the first day of voting, announcing that Blanco and Patel would remain on the ballot until they had exhausted all avenues of appeal.  The release is quoted below.

{{{As the Chair of the ASUCD Elections Committee, and in concurrence with the other members, I have decided by the power vested within me
by ASUCD Bylaw 406.F, to certify the ballot for the Winter 2010 General Election with Sergio Blanco and Vishakha Patel remaining as official
candidates for President and Vice President.

The recent decision by the ASUCD Court infringes on the right of eligible students to run for office and neglected the procedural and
substantive due process rights of Mr. Blanco and Ms. Patel guaranteed to them by the ASUCD Constitution, the Constitution of the State
of California, and the Constitution of the United States.  The ASUCD Constitution clearly retains for the Elections Committee original
jurisdiction over questions of election law.  As such, this case falls outside of the jurisdiction of the ASUCD Court.  It is the responsibility
of the Elections Committee to ensure a fair election, in compliance with the Constitution and Bylaws.  To remove a candidate from the
ballot directly violates ASUCD Bylaw 413.E, which states that no candidate shall be removed from the ballot until they have lost all
potential appeals and the ASUCD Constitution, which states that the Court cannot sanction a candidate.  Mr. Blanco and Ms. Patel
were not parties to the first case, and they have given written notice to the ASUCD that they intend to challenge the action of the Court.
Clearly, they have not lost all potential appeals.  As such, the Elections Committee cannot remove them from the ballot.

We maintain that the right of the students to vote is null and void without the right to vote for candidates of their choice.  We are not
willing to violate the ASUCD Constitution and Bylaws by denying the substantive right of a candidate to run for office and for students
to vote for a candidate of their choice.}}}

Apparently nobody ever explained to Nick Sidney the difference between original and appellate jurisdiction. LOL!
 Technically, Golden brought the case to the Court under the assumption that the Committees policy was an original ruling that could be appealed to the Court. But the Committees policy is an executive function, whereas it could be argued that challenging the policy might require a hearing before the Elections Committee sitting as a court of original jurisdiction. The elections bylaws are clear on how to submit an elections violation charge that occurs during an election that can result in violation points, but they dont envision an alleged error that takes place before the elections period. Users/JeremyKoo

Senate Race
The terms of Senators Joemar Clemente, Justin Gold, Kevin Massoudi, Previn Witana, Shawdee Rouhafza, and Trevor Taylor expired at the ASUCD Senate Senate meeting following the election, February 25, 2010.  The winners received their Certificates of Election and took office at that meeting.  3 LEAD Senators, 1 ACT Senator, and 2 Independent independents left office.

Candidates
The Elections Committee does not require candidates to note slate affiliations with their candidacy paperwork.

Independent Independents
  Christopher Adams
  Subhan Cheema, Internal Affairs Commission Member, Picnic Day Picnic Days Administrative Services Director
   Depending on the election results, the controversy surrounding Blancos appearance on the ballot could have applied to Cheema as well.
  Darwin Moosavi, Environmental Policy and Planning Commission chair
   Moosavi withdrew his candidacy and did not appear on the ballot.

Independent Independents Running Together
  Adam Thongsavat, Former Elections Committee  chair
  Raj Kumar, Former Elections Committee  Events Coordinator

JAM slate
  Selisa Romero
  Basile Senesi
  Alison Tanner, Gender and Sexuality Commission member

LEAD slate
  Ozzy Arce, External Affairs Commission Member
  Osahon Ekhator
  Rudy Ornelas, Former ASUCD Court Associate Justice
  Kirstin Stone, Business and Finance Commission member
  David Turkell, Former Director of Students For Barack Obama in Southern California
  Liz Walz

California Aggie Endorsements
The California Aggie editorial board meets with all candidates and considers their platforms and statements at its candidates forum to make its endorsements.  In http://theaggie.org/article/2010/02/11/columnasucdendorsements its Thursday, February 11th edition, it announced its endorsements.
For Executive Office
1. LEAD ticket Jack Zwald for President and Previn Witana for Vice President
  The article did not officially set a further order, but it gave positive comments to JAM ticket Sergio Blanco for President and Vishakha Patel for Vice President without even naming the Independent Greg Webb Webb/Jessica Martin Martín ticket.
For Senate
1. Rudy Ornelas (LEAD)
2. Adam Thongsavat (Independent)
3. David Turkell (LEAD)
4. Ozzy Arce (LEAD)
5. Alison Tanner (JAM)
6. Subhan Cheema (Independent)

  Electing these candidates would have yielded a Senate composed of 6 LEAD Senators (no change), 3 JAM Senators (+1), and 3 Independent Independents (no change), and the extinction of the ACT slate (1).

Links
  http://www.jtleathers.com/asucd/2010_Winter/winter2010overview.html Winter 2010 Ballot Data and Reports

20100121 13:29:56 nbsp Users/BrentLaabs caught me using weasel words.

But seriously, who else is running for anything?  Is the list of persons who have taken out a petition a matter of public record? Users/JeremyKoo
  No but nothing stays a secret for long.  Users/GregWebb
  Ive never understood the lets keep it a secret until the last minute mentality of these slates.  SGAO keeps it a secret because, well, some of the SJA checks might come back positive.  But really, isnt campaigning all about getting your name out?  Thats why Rob Roy was the first candidate to win in round 1  he was out campaigning by the first week of January.  I guess the slates can play tricks by attacking each others constituencies, but ASUCD is so incestuous that its not like information doesnt get around anyway.  All theyre doing is limiting their public interactions.  Well, I guess it makes sense if theyre all lazy. Users/BrentLaabs

20100129 21:33:11 nbsp Well, the list is up now.  Ive added any current/past ASUCD positions for the senate candidates as told by the wiki+ASUCD website.  Good luck everyone! Users/RyanMeyerhoff

20100129 22:01:28 nbsp Interesing list.  My first thought: Wow, is the Elections Committee Slate back? Users/BrentLaabs

20100131 12:58:26 nbsp Is it the general sentiment that elections are never won at the Forum, but can certainly be lost, either by failure to get your name out (read: Logan Taylor, despite a #2 Aggie endorsement (Fall 2009)) or gaffe (read: Burke Rosen and rape victims (Winter 2009))? Users/JeremyKoo
  As a former Senate candidate (twice) and Elections Committee Chair (twice), my sentiment is that the Forum has little to no impact because the people who attend (as opposed to the people just trying to eat lunch) tend to be there in support of a person or people already. And unless something has changed in the past few years, there are also very few people who attend to begin with. I think the only real impact it has is by people reading about it in the Aggie. Whether the Aggie has much of an impact is another question entirely. Their endorsements have little to no impact in my opinion. And the fact that I was endorsed #1 by the Aggie and didnt get elected is not why I say that.  JonathonLeathers

20100204 03:07:56 nbsp So, that court case sounds like fun. I miss ASUCD Elections Committee controversy. Someone post more details so I can relive my college years through Davis Wiki! Users/JonathonLeathers
  wiki:court:Case 48: Golden v ASUCD Elections Committee Done. Users/JeremyKoo

20100213 20:00:11 nbsp Im honestly not seeing it Brent.  Bylaw 407A says a writein candidates votes can only be tallied if they have registered with the Elections Committee no later than seven academic days prior to the first day of the Election.  Election Day is Feb 17th, which is 3 academic days away, and Sidney told me today that Blanco has not filed for writein candidacy. Users/JeremyKoo
 407A reads:
  For a writein candidate or Ticket to be recognized and his/her/their votes tallied, he/she/they must be registered with the ASUCD Elections Committee no later than seven (7) academic days prior to the first day of the Election.
 Did Blanco/Patel register to become a candidate prior to a week before the election?  Yes, they submitted paperwork to be a candidate within 24 hours of the Mandatory Meeting.  In fact the Elections Committee erred (and according to you, continues to err) in their interpretation of the work submitted.  The request to be a candidate at that time could only be a request to be a writein candidate.  The only thing the candidate is required to do besides notify the Elections Committee of intent is:
  Upon registration, the writein candidate(s) or Ticket(s) must submit a list of reasonable misspellings of their first and last names.  This list is not to exceed ten (10) misspellings of the candidate(s) or Ticket(s) first name(s) and ten (10) misspellings of the last name(s).  A writein candidate or Ticket must use his/her/their first name(s) and last name(s).
 We may interpret that they either failed to submit a list (the text reads must, not shall), or that the EC erred in not requiring one at that time, but either way Blanco/Patel should be considered as a writein candidate.  Even though it says that the Elections Committee must approve the list, it does not mean that this will be the only list used in the election.  Bylaw 409A states:
  The ASUCD Elections Committee shall oversee the tabulation of votes cast in every ASUCD Election held under the authority of the ASUCD Constitution and Chapter Four of the ASUCD Bylaws.
 This clause grants the Elections Committee broad authority to determine which votes could be considered valid votes for a candidate, meaning that a vote for Serjio Blanko could still be counted.
 Plus, the writein statutes are pretty vague.  I mean heck, it doesnt even say that writeins need to submit signatures to be valid.  Note that Blanco/Patel still meet all criteria to be eligible candidates, just not official candidates.
 Furthermore, this fits with the spirit of the writein law.  So you messed up the paperwork, or entered the race late.  You can still run, just not with as many benefits.  So even if you argue that the above interpretation is a stretch, it is perfectly in line with the spirit of the writein rules. And it has the added sideeffect of getting you all out of yet another constitutional crisis with the administration breathing down your necks.
 I assumed that Blanco would be joindered to the case and had presented an adequate defense, but it appears that it did not happen.  I mainly took the side of the plaintiff because ASUCD insiders rarely want to be the ones who kick other insiders out, and I wanted to make sure that Golden (a relative outsider) was well represented.  It appears that this failed to happen in this case (did no one seriously consider wiki:wikipedia:Laches (equity) laches even?).   Users/BrentLaabs
  I like that quite a lot, though the Court might take its Golden rule (see what I did there?) and extend it to mean, Regardless of the Elections Committees failure to require it of candidates seeking to be named on the ballot, because the Blanco/Patel ticket did not submit a list of ten misspellings by the deadline for writein candidates to do so (7 days before Election Day), the Committee shall not count any votes cast for a Blanco/Patel ticket.
  I think Whitney and Miller both consider laches in their dissents, without naming it specifically, but Im the only one to mention it specifically in my brief (and helpfully define it in a footnote for them!).  The Court has set a standard that it expects the candidates to either be clairvoyant and just know when the Elections Committee is exceeding its authority, or else mistrust anything and everything the Elections Committee says.
  Blanco was present at the hearing, and I dont know if there was any attempt to permit him to offer a defense, but the Court did not name him a real party and had to depend on Nick Sidney for his defense.  Sidney concentrated hard on upholding the Elections Committees policy and the Court spent little time in oral argument examining what the remedy Golden proposed, disqualifying Blanco/Patel, would mean in terms of equity.  Little time too was spent examining whether the Court even had a banstick to use against the Blanco/Patel ticket, and I think that through no fault of Nick Sidney, whose only interest should have been the Elections Committee, Blanco was not wellserved by Sidneys defense of the Elections Committee and deserved his own opportunity at defense.   Users/JeremyKoo
   Well, if Blanco was present, I guess its his own fault he didnt move to be considered a party to the case.  Or submit a brief.  The lack of briefs in this case was kinda stunning.  LOL Golden Rule.  But seriously, the must submit wording implies that its required in order for the list to be considered.  If it was shall submit instead, it would look more like a requirement without which the writein candidacy would be invalid.
   My attention has now been drawn to how lame the rules for writein candidates are.  For instance, they can apply to be a write in candidate seven days before the election (407A), but are not eligible for office if they didnt attend the Mandatory Meeting weeks beforehand (404A7).  Oops.  This obviously doesnt have any bearing in the instant case, but Im sorry I didnt fix this sooner.  Hopefully IAC will look at the writein rules and make them nicer in the near future.   Users/BrentLaabs
   The Court has set a standard that it expects the candidates to either be clairvoyant and just know when the Elections Committee is exceeding its authority, or else mistrust anything and everything the Elections Committee says. You dont have to be clairvoyant to read the Election Bylaws. Anyone can read the Bylaws and see that there are no rules for extending signature gathering deadlines. I always made a point of telling the candidates at the Mandatory Candidates Meeting that it was their responsibility to know the Election rules because regardless of what they think as candidates or I say as Elections Committee Chair, the Bylaws are what matter. Oh, and if the past has taught anything, its that you should mistrust the Elections Committee... they/we have a habit of getting things wrong and making up rules.  JonathonLeathers

20100215 22:43:04 nbsp It appears weve scooped the Tuesday California Aggie Aggie on the Court ruling, despite them having the extra holiday, and despite their Twitter stream receiving a tweet from http://twitter.com/ucdaction/status/9043490829 @ucdaction. Users/JeremyKoo

20100216 15:16:43 nbsp Well, now this just got interesting because now its become a question of the Courts role overall.  We may remember that the Supreme Court of the United States depends on the respect from executive and legislative branches for enforcement of its rulings.  The ASUCD Court, comparatively, is still in its infancy, and has to make decisions that also consider the other branches likelihoods that they will respect its ruling.  It would seem that the Court failed to account for this.

Also, lets assume Blanco wins, because its all moot if he doesnt, then youll have the EC certify, the Court voiding that certification and ordering the EC to reconsider in light of a new opinion, and the EC standing its ground and refusing to certify any candidate for Executive Office.  Then we might reasonably assume the new Senate gets to deal with a vacancy in both the office of President and Vice President which starts at the end of the last Senate meeting of winter quarter.  In this case, the Senate President Pro Tempore becomes President at the end of the last Senate meeting of Winter quarter under Art III, Sec 5, Clause 3, and appoints a Vice President approved by majority vote of the Senate.

But who would be this Senator?  Well, since under Art II, Sec 6 the Senate does not choose a Senate President Pro Tempore until the first meeting of the new quarter, the current PPT becomes President.  Someone start the betting on ASUCD President Andre Lee. Users/JeremyKoo

 What is the likelihood of them winning? Im out of the loop and have no clue. ASUCD had two ineligible candidates win Senate seats and become Senators. Maybe that can be topped when two ineligible candidates (they didnt have enough signatures, theyre ineligible, its not rocket science) become President and Vice President.  JonathonLeathers
  Id say there is a 30% chance of them winning. Zwald got the Aggie endorsement and seems to be reaching out to a lot of people. Webb isnt even in the running. wl
  Yeah seriously, I dont think theres much of a chance of Sergio Blanco winning.  To the extent that Zwald was opposed to this whole court case deal, because he thinks it would be better for him politically for him to win a more sporting contest against Blanco.  Apparently he doesnt know that, and thinks this is some kind of LEAD conspiracy.  But LEAD has been trying to stay as far away from this as possible, with only a little covert help in favor of Blanco.  Webb reminds me of myself in high school:  running for office three times, always losing, and then running for class president.  (I lost.) Users/BrentLaabs

20100219 15:06:22 nbsp Blanco and Patel were one vote shy of being 1337... Users/PaulAmnuaypayoat
 One more vote and they would have been automatically elected! Thats gotta be in the bylaws somewhere, hidden among one of those reform packages that went on the ballot and everyone voted yes on but didnt read.  JonathonLeathers

20100306 20:03:13 nbsp Heres what Andrew Jackson initially said about the Supreme Court the decision of the supreme court has fell still born, and they find that they cannot coerce Georgia to yield to its mandate. Users/PrevinWitana


text:
MODULE bsimple
  !
  !  Purpose:
  !    To define the derived data type used as a node in the
  !    binary tree, and to define the operations >, <. and ==
  !    for this data type.  This module also contains the
  !    subroutines to add a node to the tree, write out the
  !    values in the tree, and find a value in the tree.
  !
  !  Record of revisions:
  !      Date       Programmer          Description of change
  !      ====       ==========          =====================
  !    12/24/06    S. J. Chapman        Original code
  !
  USE typedefs
  USE parameters
  !  USE subroutines
  IMPLICIT NONE

  ! Restrict access to module contents.
  PRIVATE
  PUBLIC :: node, OPERATOR(>), OPERATOR(<), OPERATOR(==)
  PUBLIC :: add_node, write_node, find_node, find_min, delete_node, find_previous

  INTERFACE OPERATOR (>)
     MODULE PROCEDURE greater_than
  END INTERFACE OPERATOR (>)

  INTERFACE OPERATOR (<)
     MODULE PROCEDURE less_than
  END INTERFACE OPERATOR (<)

  INTERFACE OPERATOR (==)
     MODULE PROCEDURE equal_to
  END INTERFACE OPERATOR (==)

CONTAINS
  RECURSIVE SUBROUTINE add_node (ptr, new_node)
    !
    !  Purpose:
    !    To add a new node to the binary tree structure.
    !
    TYPE (node), POINTER :: ptr  ! Pointer to current pos. in tree
    TYPE (node), POINTER :: new_node ! Pointer to new node

    IF ( .NOT. ASSOCIATED(ptr) ) THEN
       ! There is no tree yet.  Add the node right here.
       ptr => new_node
    ELSE IF ( new_node < ptr ) THEN
       !      IF ( (new_node%iy) .EQ. 2 .AND. (new_node%iz .EQ. 2) ) PRINT *, new_node%tau,"<",ptr%tau
       IF ( ASSOCIATED(ptr%before) ) THEN
          CALL add_node ( ptr%before, new_node )
       ELSE
          ptr%before => new_node
          new_node%parent => ptr
          new_node%leftRight = 0
       END IF
    ELSE
       !      IF ( (new_node%iy) .EQ. 2 .AND. (new_node%iz .EQ. 2) ) PRINT *, new_node%tau,">",ptr%tau
       IF ( ASSOCIATED(ptr%after) ) THEN
          CALL add_node ( ptr%after, new_node )
       ELSE
          ptr%after => new_node
          new_node%parent => ptr
          new_node%leftRight = 1
       END IF
    END IF
  END SUBROUTINE add_node

  RECURSIVE SUBROUTINE write_node (ptr)
    !
    !  Purpose:
    !    To write out the contents of the binary tree
    !    structure in order.
    !
    TYPE (node), POINTER :: ptr  ! Pointer to current pos. in tree

    ! Write contents of previous node.
    IF ( ASSOCIATED(ptr%before) ) THEN
       CALL write_node ( ptr%before )
    END IF

    ! Write contents of current node.
    !WRITE (*,*) ptr%tau, ptr%ix, ptr%iy, ptr%iz

    ! Write contents of next node.
    IF ( ASSOCIATED(ptr%after) ) THEN
       CALL write_node ( ptr%after )
    END IF
  END SUBROUTINE write_node

  RECURSIVE SUBROUTINE find_node (ptr, search, error)
    !
    !  Purpose:
    !    To find a particular node in the binary tree structure.
    !    "Search" is a pointer to the name to find, and will
    !    also contain the results when the subroutine finishes
    !    if the node is found.
    !
    TYPE (node), POINTER :: ptr    ! Pointer to curr pos. in tree
    TYPE (node), POINTER :: search ! Pointer to value to find.
    INTEGER :: error               ! Error: 0 = ok, 1 = not found

    IF ( search < ptr ) THEN
       IF ( ASSOCIATED(ptr%before) ) THEN
          CALL find_node (ptr%before, search, error)
       ELSE
          error = 1
       END IF
    ELSE IF ( search == ptr ) THEN
       search = ptr
       error = 0
    ELSE
       IF ( ASSOCIATED(ptr%after) ) THEN
          CALL find_node (ptr%after, search, error)
       ELSE
          error = 1
       END IF
    END IF
  END SUBROUTINE find_node

  RECURSIVE SUBROUTINE find_previous (ptr, search, prevNode, leftRight, error)
    !
    !  Purpose:
    !    To find the node just prior to the one of interest
    !
    TYPE (node), POINTER :: ptr    ! Pointer to curr pos. in tree
    TYPE (node), POINTER :: search ! Pointer to value to find.
    TYPE (node), POINTER :: prevNode ! Pointer to value to find.
    INTEGER :: error               ! Error: 0 = ok, 1 = not found
    INTEGER :: leftRight
    INTEGER :: assocstat

    ! PRINT *, "Now in find previous"
    ! PRINT *, "ptr at",ptr%ix,ptr%iy,ptr%iz,ptr%tau
    ! PRINT *, "search at",search%ix,search%iy,search%iz,search%tau
    leftRight = 99
    assocstat = 0

    ! Find association status of the pointers
    IF ( ASSOCIATED(ptr%before) .AND. ASSOCIATED(ptr%after) ) THEN
       assocstat = 1
    ELSE IF ( ASSOCIATED(ptr%before) ) THEN !.AND. (.NOT. ASSOCIATED(ptr%after)))) THEN
       assocstat = 2
    ELSE IF ( ASSOCIATED(ptr%after) ) THEN !.AND. (.NOT. ASSOCIATED(ptr%before))) THEN
       assocstat = 3
    END IF

    SELECT CASE (assocstat)
    CASE(0)
       PRINT *, "Both pointers null! Exiting!!"
       PRINT *, "search=",search%tau,search%omega,search%ix,search%iy,search%iz
       PRINT *, "ptr=",ptr%tau,ptr%omega,ptr%ix,ptr%iy,ptr%iz
       PRINT *, "Now writing ptr"
       CALL write_node(ptr)
       PRINT *, "Now writing search:"
       CALL write_node(search)
       error = 1
       CALL EXIT()
    CASE(1)
       IF ( search == ptr%before ) THEN
          prevNode => ptr
          error = 0
          leftRight = 0
       ELSE IF ( search == ptr%after ) THEN
          !      PRINT *, search%tau,"=after",ptr%tau
          prevNode => ptr
          error = 0
          leftRight = 1
       ELSE IF ( search < ptr ) THEN
          !      PRINT *, search%tau," is less than ptr%before"
          CALL find_previous (ptr%before, search, prevNode, leftRight, error)
       ELSE
          CALL find_previous (ptr%after, search, prevNode, leftRight, error)
       END IF
    CASE(2)
       IF ( search == ptr%before ) THEN
          prevNode => ptr
          error = 0
          leftRight = 0
       ELSE
          CALL find_previous (ptr%before, search, prevNode, leftRight, error)
       END IF
    CASE(3)
       IF ( search == ptr%after ) THEN
          !      PRINT *, search%tau,"=after",ptr%tau
          prevNode => ptr
          error = 0
          leftRight = 1
       ELSE
          CALL find_previous (ptr%after, search, prevNode, leftRight, error)
       END IF
    END SELECT
    !    PRINT *, "End find_previous"
  END SUBROUTINE find_previous

  RECURSIVE SUBROUTINE find_min (ptr, search)
    IMPLICIT NONE
    TYPE (node), POINTER :: ptr    ! Pointer to curr pos. in tree
    TYPE (node), POINTER :: search ! Pointer to minimum value

    IF ( ASSOCIATED(ptr%before) ) THEN
       CALL find_min ( ptr%before, search )
    ELSE
       search => ptr
    END IF
  END SUBROUTINE find_min

  RECURSIVE SUBROUTINE find_max (ptr, search)
    IMPLICIT NONE
    TYPE (node), POINTER :: ptr    ! Pointer to curr pos. in tree
    TYPE (node), POINTER :: search ! Pointer to minimum value

    IF ( ASSOCIATED(ptr%after) ) THEN
       CALL find_min ( ptr%after, search )
    ELSE
       search => ptr
    END IF
  END SUBROUTINE find_max

  RECURSIVE SUBROUTINE delete_node (root, toDelete, prevNode, nextNode, error)
    !
    !  Purpose:
    !    To find a particular node in the binary tree structure.
    !    "Search" is a pointer to the name to find, and will
    !    also contain the results when the subroutine finishes
    !    if the node is found.
    !
    TYPE (node), POINTER :: toDelete ! Node to delete
    TYPE (node), POINTER :: root     ! Root node
    TYPE (node), POINTER :: prevNode, nextNode
    INTEGER :: error                 ! Error: 0 = ok, 1 = not found
    INTEGER :: dType                 ! Deletion type: 0 = leaf node, 1 = one child, 2 = two children
    INTEGER :: d1,d2,d3              ! Coordinates 1, 2, and 3
    INTEGER :: onetype
    INTEGER :: twotype

    d1 = toDelete%ix
    d2 = toDelete%iy
    d3 = toDelete%iz

    CALL node_type(toDelete,dType,onetype,twotype,0)
    IF ( VERBOSE .EQV. .TRUE. ) THEN
       IF ( dType .EQ. 1 ) PRINT *, "dType=",dType,"onetype=",onetype
       IF (dType .EQ. 2 ) PRINT *, "dType=",dType,"twotype=",twotype
    END IF

    SELECT CASE (dType)
    CASE (0)
       ! Since toDelete corresponds to a persistant lattice site, we just nullify
       ! the pointers and will re-add it to the tree later
       IF ( toDelete == root ) THEN
          NULLIFY(root)
          RETURN
       ELSE
          prevNode => toDelete%parent
          IF ( toDelete%leftRight .EQ. 0 ) THEN
             NULLIFY(prevNode%before,toDelete%parent)
          ELSE IF ( toDelete%leftRight .EQ. 1 ) THEN
             NULLIFY(prevNode%after,toDelete%parent)
          ELSE
             IF ( toDelete == root ) THEN
                CONTINUE
             ELSE
                PRINT *, "leftRight=",toDelete%leftRight
                !            CALL write_matrix_dataframe(root%ix,root%iy,root%iz)
                !            CALL write_matrix_dataframe(toDelete%ix,toDelete%iy,toDelete%iz)
                CALL EXIT()
             END IF
          END IF
       END IF
       toDelete%leftRight = -1
    CASE (1)
       SELECT CASE (onetype)
       CASE (0)
          PRINT *, "Error in onetype case: onetype=0"
          CALL EXIT()
       CASE (1)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "onetype=",onetype
          nextNode => toDelete%before
          prevNode => toDelete%parent
          nextNode%parent => prevNode        ! 1
          nextNode%leftRight = 0             ! 2
          prevNode%before => nextNode        ! 3
       CASE (2)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "onetype=",onetype
          nextNode => toDelete%before
          prevNode => toDelete%parent
          nextNode%parent => prevNode        ! 1
          prevNode%after =>  nextNode        ! 2
          nextNode%leftRight = 1             ! 3
       CASE (3)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "onetype=",onetype
          nextNode => toDelete%after
          prevNode => toDelete%parent
          nextNode%parent => prevNode        ! 1
          prevNode%before => nextNode        ! 2
          nextNode%leftRight = 0             ! 3
       CASE (4)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "onetype=",onetype
          nextNode => toDelete%after
          prevNode => toDelete%parent
          nextNode%parent => prevNode        ! 1
          prevNode%after => nextNode         ! 2
          nextNode%leftRight = 1             ! 3
       CASE (5)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "onetype=",onetype
          nextNode => toDelete%before
          NULLIFY(nextNode%parent)           ! 1
          nextNode%leftRight = -1            ! 2
          root => nextNode                   ! 3
       CASE (6)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "onetype=",onetype
          nextNode => toDelete%after
          NULLIFY(nextNode%parent)           ! 1
          nextNode%leftRight = -1            ! 2
          root => nextNode                   ! 3
       END SELECT
       IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "Nullifying pointers"
       NULLIFY(matrix(d1,d2,d3)%before,matrix(d1,d2,d3)%after,matrix(d1,d2,d3)%parent)
       matrix(d1,d2,d3)%leftRight = -1
       IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "Pointers nullified"
    CASE (2)
       ! First step is to delete the min of toDelete%after
       CALL find_min(toDelete%after,nextNode)
       toDelete => nextNode
       CALL delete_node(root,toDelete,prevNode,nextNode,error)
       SELECT CASE (twotype)
       CASE (1)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "twotype=",twotype
          prevNode => matrix(d1,d2,d3)%before
          prevNode%parent => toDelete ! 1
          toDelete%before => prevNode ! 2
          root => toDelete
       CASE (2)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "twotype=",twotype
          prevNode => matrix(d1,d2,d3)%before
          nextNode => matrix(d1,d2,d3)%after
          prevNode%parent => toDelete ! 1
          nextNode%parent => toDelete ! 2
          toDelete%before => prevNode ! 3
          toDelete%after  => nextNode ! 4
          root => toDelete
       CASE (3)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "twotype=",twotype
          prevNode => matrix(d1,d2,d3)%before
          prevNode%parent => toDelete ! 1
          toDelete%before => prevNode ! 2
          root => toDelete
       CASE (4)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "twotype=",twotype
          prevNode => matrix(d1,d2,d3)%before
          nextNode => matrix(d1,d2,d3)%after
          prevNode%parent => toDelete ! 1
          nextNode%parent => toDelete ! 2
          toDelete%before => prevNode ! 3
          toDelete%after  => nextNode ! 4
          root => toDelete
       CASE (5)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "twotype=",twotype
          prevNode => matrix(d1,d2,d3)%before
          prevNode%parent => toDelete                     ! 1
          toDelete%before => prevNode                     ! 2
          toDelete%parent => matrix(d1,d2,d3)%parent      ! 3
          toDelete%leftRight = matrix(d1,d2,d3)%leftRight ! 4
          prevNode => matrix(d1,d2,d3)%parent
          IF ( toDelete%leftRight .EQ. 0 ) THEN           ! 5
             prevNode%before => toDelete
          ELSE
             prevNode%after  => toDelete
          END IF
       CASE (6)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "twotype=",twotype
          prevNode => matrix(d1,d2,d3)%before
          nextNode => matrix(d1,d2,d3)%after
          prevNode%parent => toDelete                     ! 1
          nextNode%parent => toDelete                     ! 2
          toDelete%before => prevNode                     ! 3
          toDelete%after  => nextNode                     ! 4
          toDelete%parent => matrix(d1,d2,d3)%parent      ! 5
          toDelete%leftRight = matrix(d1,d2,d3)%leftRight ! 6
          prevNode => matrix(d1,d2,d3)%parent
          IF ( toDelete%leftRight .EQ. 0 ) THEN           ! 7
             prevNode%before => toDelete
          ELSE
             prevNode%after => toDelete
          END IF
       CASE (7)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "twotype=",twotype
          prevNode => matrix(d1,d2,d3)%before
          prevNode%parent => toDelete                     ! 1
          toDelete%before => prevNode                     ! 2
          toDelete%parent => matrix(d1,d2,d3)%parent      ! 3
          toDelete%leftRight = matrix(d1,d2,d3)%leftRight ! 4
          prevNode => matrix(d1,d2,d3)%parent
          IF ( toDelete%leftRight .EQ. 0 ) THEN           ! 5
             prevNode%before => toDelete
          ELSE
             prevNode%after  => toDelete
          END IF
       CASE (8)
          IF ( VERBOSE .EQV. .TRUE. ) PRINT *, "twotype=",twotype
          prevNode => matrix(d1,d2,d3)%before
          nextNode => matrix(d1,d2,d3)%after
          prevNode%parent => toDelete                     ! 1
          nextNode%parent => toDelete                     ! 2
          toDelete%before => prevNode                     ! 3
          toDelete%after  => nextNode                     ! 4
          toDelete%parent => matrix(d1,d2,d3)%parent      ! 5
          toDelete%leftRight = matrix(d1,d2,d3)%leftRight ! 6
          prevNode => matrix(d1,d2,d3)%parent
          IF ( toDelete%leftRight .EQ. 0 ) THEN           ! 7
             prevNode%before => toDelete
          ELSE
             prevNode%after => toDelete
          END IF
       END SELECT
       NULLIFY(matrix(d1,d2,d3)%before,matrix(d1,d2,d3)%after,matrix(d1,d2,d3)%parent)
       matrix(d1,d2,d3)%leftRight = -1
    END SELECT
  END SUBROUTINE delete_node

  LOGICAL FUNCTION greater_than (op1, op2)
    !
    !  Purpose:
    !    To test to see if operand 1 is > operand 2
    !    in alphabetical order.
    !
    TYPE (node), INTENT(IN) :: op1, op2

    IF (op1%tau > op2%tau) THEN
       greater_than = .TRUE.
    ELSE IF ( op1%tau == op2%tau ) THEN
       IF ( op1%ix > op2%ix ) THEN
          greater_than = .TRUE.
       ELSE IF ( op1%ix == op2%ix ) THEN
          IF ( op1%iy > op2%iy ) THEN
             greater_than = .TRUE.
          ELSE IF ( op1%iy == op2%iy ) THEN
             IF ( op1%iz > op2%iz ) THEN
                greater_than = .TRUE.
             ELSE
                greater_than = .FALSE.
             END IF
          ELSE
             greater_than = .FALSE.
          END IF
       ELSE
          greater_than = .FALSE.
       END IF
    ELSE
       greater_than = .FALSE.
    END IF
  END FUNCTION greater_than

  LOGICAL FUNCTION less_than (op1, op2)
    !
    !  Purpose:
    !    To test to see if operand 1 is < operand 2
    !    in alphabetical order.
    !
    TYPE (node), INTENT(IN) :: op1, op2

    IF (op1%tau < op2%tau) THEN
       less_than = .TRUE.
    ELSE IF ( op1%tau == op2%tau ) THEN
       IF ( op1%ix < op2%ix ) THEN
          less_than = .TRUE.
       ELSE IF ( op1%ix == op2%ix ) THEN
          IF ( op1%iy < op2%iy ) THEN
             less_than = .TRUE.
          ELSE IF ( op1%iy == op2%iy ) THEN
             IF ( op1%iz < op2%iz ) THEN
                less_than = .TRUE.
             ELSE
                less_than = .FALSE.
             END IF
          ELSE
             less_than = .FALSE.
          END IF
       ELSE
          less_than = .FALSE.
       END IF
    ELSE
       less_than = .FALSE.
    END IF
  END FUNCTION less_than

  LOGICAL FUNCTION equal_to (op1, op2)
    !
    !  Purpose:
    !    To test to see if operand 1 is equal to operand 2
    !    alphabetically.
    !
    TYPE (node), INTENT(IN) :: op1, op2

    IF ( (op1%tau == op2%tau ) .AND. &
         (op1%ix == op2%ix) .AND. &
         (op1%iy == op2%iy) .AND. &
         (op1%iz == op2%iz) ) THEN
       equal_to = .TRUE.
    ELSE
       equal_to = .FALSE.
    END IF
  END FUNCTION equal_to

  RECURSIVE SUBROUTINE node_type (temp, dType, onetype, twotype, recursive )
    !
    !  Purpose:
    !    To find a particular node in the binary tree structure.
    !    "Search" is a pointer to the name to find, and will
    !    also contain the results when the subroutine finishes
    !    if the node is found.
    !
    IMPLICIT NONE
    TYPE (node), POINTER :: temp ! Node to delete
    INTEGER :: dType, dType1, dType2                 ! Deletion type: 0 = leaf node, 1 = one child, 2 = two children
    INTEGER :: onetype, twotype
    LOGICAL :: leftBranch
    LOGICAL :: rightBranch
    !    LOGICAL :: recursive
    INTEGER :: recursive

    dType       = 0
    dType1      = 0
    dType2      = 0
    onetype     = 0
    twotype     = 0
    leftBranch  = .FALSE.
    rightBranch = .FALSE.

    IF ( ASSOCIATED(temp%before) ) THEN
       ! PRINT *, "Before node="
       CALL write_node(temp%before)
       dType = dType + 1
       leftBranch = .TRUE.
    END IF

    IF ( ASSOCIATED(temp%after)) THEN
       ! PRINT *, "After node="
       CALL write_node(temp%after)
       dType = dType + 1
       rightBranch = .TRUE.
    END IF

    ! Determine Type 1 case
    IF ( dType .EQ. 1 ) THEN
       IF ( (temp%leftRight .EQ. 0) .AND. (leftBranch .EQV. .TRUE. ) ) THEN
          onetype = 1
       ELSE IF ( (temp%leftRight .EQ. 1) .AND. (leftBranch .EQV. .TRUE.) ) THEN
          onetype = 2
       ELSE IF ( (temp%leftRight .EQ. 0) .AND. (rightBranch .EQV. .TRUE. ) ) THEN
          onetype = 3
       ELSE IF ( (temp%leftRight .EQ. 1) .AND. (rightBranch .EQV. .TRUE.) ) THEN
          onetype = 4
       ELSE IF ( (temp%leftRight .EQ. -1) .AND. (leftBranch .EQV. .TRUE.) ) THEN
          onetype = 5
       ELSE IF ( (temp%leftRight .EQ. -1) .AND. (rightBranch .EQV. .TRUE.) ) THEN
          onetype = 6
       END IF
    END IF

    IF ( dType .EQ. 2 ) THEN
       !      IF ( recursive .EQV. .TRUE. ) THEN
       IF ( recursive == 0 ) THEN
          !        recursive = .FALSE.
          CALL node_type(temp%before,dType1,onetype,twotype,1)
          CALL node_type(temp%after,dType2,onetype,twotype,1)
          IF ( .NOT. ASSOCIATED(temp%parent) ) THEN
             ! Root node
             IF ( (dType1 .EQ. 0) .AND. (dType2 .EQ. 0 ) ) THEN
                twotype = 1
             ELSE IF ( (dType1 .EQ. 0) .AND. (dType2 .NE. 0 ) ) THEN
                twotype = 2
             ELSE IF ( (dType1 .NE. 0) .AND. (dType2 .EQ. 0 ) ) THEN
                twotype = 3
             ELSE IF ( (dType1 .NE. 0) .AND. (dType2 .NE. 0 ) ) THEN
                twotype = 4
             END IF
          ELSE
             ! Not root node
             IF ( (dType1 .EQ. 0) .AND. (dType2 .EQ. 0 ) ) THEN
                twotype = 5
             ELSE IF ( (dType1 .EQ. 0) .AND. (dType2 .NE. 0 ) ) THEN
                twotype = 6
             ELSE IF ( (dType1 .NE. 0) .AND. (dType2 .EQ. 0 ) ) THEN
                twotype = 7
             ELSE IF ( (dType1 .NE. 0) .AND. (dType2 .NE. 0 ) ) THEN
                twotype = 8
             END IF
          END IF
       ELSE
          RETURN
       END IF
    END IF
  END SUBROUTINE node_type
END MODULE bsimple

max_stars_repo_name: cnshingledecker/kmc-spin

max_issues_repo_name: cnshingledecker/kmc-spin

max_forks_repo_name: cnshingledecker/kmc-spin


text:
	subroutine readonly(inunit,iwhich,numb,srate,signal,isize,ierr)

c read in max. size of storage array - BMS July 25 2002
CM _ MVAX version - CM
c routine to read the meat of a D/A or A/D signal 	BMS June 25 1990
c A/D comment removed             BMS Oct 12 1990
c Put inverse stuff in common & add the boom inflection point
c definitions - BMS Oct 25 1990
c Add the inverse filter sample rate and delay value - Nov 6 1990
c Accept only 32764 samples (that's all D_AOUTPUT, etc, will use) - Aug 28 1991
c Add the reflection parameter values - Dec 11, 1991
c Increase noinfl (again) - the possible size of the input file - July 16 2002

        logical lreflx
        real deltime,ratpress
        integer numbdel
        common /reflex/ lreflx,deltime,delphase,ratpress,numbdel

	logical lseq,ltype

	real signal(1)

	integer inunit

c pass in common the NINFL time and pressure pairs used to define this wave
        parameter (noinflp = 10000)
        real*4 press(noinflp), atime(noinflp)
        common /boomcom/ press,atime,ninfl,srate_boom

        logical linv_used
        character*80 inv_name, orig_name
        character*8 ntime
        character*9 ndate
        common /footer/ linv_used, inv_name, orig_name, srate_inv_used,
     $             idelay_used, ntime, ndate

c	print *,'In readonly ',isize
	ierr = 0
	read (inunit,err=8000,end=8010) numb,srate
	if (numb .gt. isize) then
	   numb = isize
	   print *,' Signal has been reduced to ',numb,' in READONLY'
	endif
	read (inunit,err=8000,end=8010) (signal(i),i=1,numb)
	read (inunit,err=9000,end=9010) ntime,ndate
	read (inunit,err=9000,end=9010) linv_used
	if (linv_used) then
	   read (inunit,err=9000,end=9010) inv_name
	   read (inunit,err=9000,end=9010) orig_name
c if Inverse srate or delay is not there, don't report an error, just ignore it
	   read (inunit,err=9020,end=9020) srate_inv_used
	   read (inunit,err=9020,end=9020) idelay_used
	else
	   inv_name = ' '
	   orig_name = ' '
	   srate_inv_used = 0.0
	   idelay_used = 0
	endif
c if NINFL is not there, don't report an error, just ignore it
	read (inunit,err=9030,end=9030) ninfl
	if (ninfl .gt. 0) then
c zero out the arrays
	   do j=1,200
	      press(j) = 0.0
	      atime(j) = 0.0
	   enddo
	   read (inunit,err=9000,end=9010) srate_boom
	   if (ninfl .le. 20) then
              read (inunit,err=9000,end=9010) (press(j),j=1,20),
     $                            (atime(j),j=1,20)
	   else
	      read (inunit,err=9000,end=9010) (press(j),j=1,ninfl),
     $                            (atime(j),j=1,ninfl)
	   endif
	endif
c if LREFLX is not there, don't report an error, just ignore it
	read (inunit,err=9040,end=9040) lreflx
	if (lreflx) then
	   read (inunit,err=9000,end=9010)
     $                       deltime,delphase,ratpress,numbdel
	else
	   deltime = 0.0
	   delphase = 0.0
	   ratpress = 0.0
	   numbdel = 0
	endif

	return

 8000	print *,' Error reading signal file'
	ierr = -1
	return

 8010	print *,' Premature end of signal file'
	ierr = -1
	return

 9000	print *,' Error reading signal file footer'
	ierr = -1
	return

 9010	print *,' Premature end of signal file footer'
	ierr = -1
	return

 9020   srate_inv_used = 0
	return

 9030   ninfl = 0
	return

 9040   lreflx = .false.
	return

	end

max_stars_repo_name: mandalin/DissertationPostProcessing

max_issues_repo_name: mandalin/DissertationPostProcessing

max_forks_repo_name: mandalin/DissertationPostProcessing


c	modification history:
c		2/5/02	replace obsolete version of sampex_timcon subr
c			with include statement pointing to version
c			on ULEIS workstation    /gm
c
c
c       The following are standard functions and subroutines used
c       frequently by STEP data analysis programs
c
c       Contents:
c             subroutine convert_time(ptime,sktime,fktime)
c
c             integer function day_of_year(yy,mm,dd)
c
c             integer function IDAYS_PER_YEAR(IYEAR)
c
c             subroutine convert_to_sampextime(iyear,idoy,ihour,imin,iseconds,stime)
c
c             subroutine sampex_timcon(stime,yyyy,mo,da,hr,mn,se,doy,isotime)
c
c
c
c***************************************************
c
      subroutine convert_time(ptime,sktime,fktime)
c
c***************************************************
c     Takes the string ptime, containing the start and finish date and time
c     of the major frame, and creates two strings:
c     sktime is the start date and time
c     fk is the finish date and time
c
c     Revisions:
c              10/6/95 by J. Dwyer  commented code
c
      character *40 ptime   ! input string
      character *24 sktime,fktime  ! output strings
c
c      iso_time_c24(1:24)='    -  -  T  :  :       '
c                          123456789012345678901234
c
      sktime(1:4)='19'//ptime(2:3)
      sktime(5:7)='-'//ptime(5:6)
      sktime(8:10)='-'//ptime(8:9)
      sktime(11:19)='T'//ptime(11:18)
      sktime(20:24)='     '
c
      fktime(1:4)='19'//ptime(21:22)
      fktime(5:7)='-'//ptime(24:25)
      fktime(8:10)='-'//ptime(27:28)
      fktime(11:19)='T'//ptime(30:37)
      fktime(20:24)='     '
c
      return
      end   ! end convert_time
c
c
c
c
c***************************************************
c
       integer function day_of_year(yy,mm,dd)
c
c***************************************************
c
c    Takes the date and returns the number of the day (1-365) in the year
c    yy = year (e.g. 1995)
c    mm = month (1-12)
c    dd = day
c
c     Revisions:
c                10/6/95 by J. Dwyer  Changed from subroutine to function and
c                                                  commented code.
c
c
      integer yy, mm, dd, mm0
      integer dm(12)/31,28,31,30,31,30,31,31,30,31,30,31/  ! days per month
c
      mm0 = mm-1
      day_of_year = dd
      if (mm0.eq.0) return
      do 4000 i=1,mm0
        day_of_year = day_of_year + dm(i)
4000    continue
      if (mm0.ge.2 .and. mod(yy,4).eq.0)
     1           day_of_year = day_of_year + 1
c
      return
      end  ! end day_of_year
c
c
c
c
c
c
c****************************************************
c
        integer function idays_per_year(iyear)
c
c****************************************************
c
c    	Function to return the number of days per year for the
c	add mod test 5/8/08   /gm
c      iyear = year (e.g. 1995)
c
c      Revisions:
c
c
	      integer	iyear
c
   	   if (mod(iyear,4).eq.0) then
	     	 idays_per_year=366
   	  else
   	  	idays_per_year=365
	     end if
c
       return
       end   ! end idays_per_year
c
c
c
c
c*****************************************************
c
       subroutine convert_to_sampextime(iyear,
     1  idoy,ihour,imin,iseconds,stime)
c
c*****************************************************
c
c   	This subroutine accepts a year, day of year, hour of day,
c	   minutes, and seconds of day and converts these to a
c	   sampex time (seconds since midnight 1 January 1992).
c
c					J. Mazur  3/25/94
c
c   	Revisions:
c                 10/6/95 by J. Dwyer added line  integer idays_per_year
c
c
	      INTEGER	IYEAR	! year
        INTEGER	IDOY	! day of year
	      INTEGER	IHOUR	! hour of day
	      INTEGER	IMIN	! minutes of day
        integer    idays_per_year
	      INTEGER*4	ISECONDS ! seconds of day
	      INTEGER*4	STIME	! sampex time
c
	      INTEGER*4	IYDUM	! year counter
	      INTEGER*4	IDAYS	! day counter
c
c	First zero the day counter (for multiple
c	calls to convert_to_sampextime)
	      IDAYS=0
c
c	Find number of days since midnight 1 Jan 1992
	      IYDUM=1992
	      DO WHILE(IYDUM.LT.IYEAR)
	         IDAYS = IDAYS + IDAYS_PER_YEAR(IYDUM)
	         IYDUM = IYDUM + 1
	      END DO
c	Add up the days, but subtract 1 since the first day
c	of 1992 was day 1, not day 0.
	      IDAYS = IDAYS + IDOY - 1
c
c	Get the number of seconds since midnight 1 Jan 1992
      	STIME = (IDAYS*86400) + (IHOUR*3600) + (IMIN*60)+ ISECONDS
c
	      RETURN
	      END  ! end convert_to_sampextime


text:
This has multiple meanings.  You are probably looking for information on one of the following:

  Alternative Film Club  A clandestine effort to watch independent films on campus
  Campus Cinema  Movies, open to the public, shown on campus.
  Davis Feminist Film Festival
  Davis Film Festival
  Filmmakers Ambitions  A group of students who make movies
  Latin American Film Series
  Movie Theaters  Places to see movies on big screens
  Retro Film Revival  A series of older films shown at Movie Theaters Holiday Cinema
  RobotMedia  A group of students who showcase student films once a quarter

This is a Disambiguation disambiguation page  a navigational aid which lists other pages that might otherwise share the same title. If an article link referred you here, you might want to go back and fix it to point directly to the intended page.