text:
Davis Student Coop will remain open this coming Fall thanks to dedicated students, Administrators, and Student Housing representatives.  For more information, visit the Save DSC page. At this point, we would like people to send in thanks to the people listed on the Save DSC page  for their dedication in working to keep the coops open for future generations of students.

Historic Davis Student Coop, or DSC (not to be confused with the Davis Senior Center), is one of three on campus coops on the UC Davis campus that offer an alternative living arrangement to students, whether they be undergraduate students undergraduate or graduate students, male or female. DSC typically has anywhere from 10 to 12 residents, depending on the number of rooms being shared. Four of the eight rooms in the house have been used as doubles where the other four are singles, with residents each getting a chance each quarter to choose their room and roommate.

Davis Student Coop residents use appropriate technology to create an ecologically sustainable and community oriented environment. We have been growing all organic since 1972. The residents are also known to cook some damn good food. All house meals are vegetarian, usually with vegan options. We make bulk purchases at the Davis Food Coop for staple goods such as flour and grain. We order bulk foods directly from local organic farms. We grow lots of organic fruit and veggies in our garden. We keep a compost pile and a worm bin.  We are caretakers for chickens whom we treat with respect and from whom we receive eggs.

The house itself is rather large with lots of places to chill out.  You may notice on many a fine night a joyous sound coming from the Coops. Music and art are popular among the residents.

The house welcomes applicants to our communal dinners every Sunday through Thursday at 7 pm. Garden parties, starting at 3:30 pm on Friday, are another great way to meet the residents. Visiting often ensures that all residents in the house will get to meet you and accept you into the community.

20060301 22:55:27 nbsp The Davis Student Coop should rename itself to something that describes what it does, unless, of course, it purchases and sells students! :) For example, the Davis Food Coop purchases and sells food. The Twin Rainbows Housing Cooperative provides housing. etc... Users/GrahamFreeman

20070409 I would call it Permaculture Coop since the general idea of the coops is to foster sustainable relationships between people, plants, animals, and the university. Oh yeah, and Ive been living at DSC for two years now and think a name change is entirely possible as weve thought about this before. Derek Downey

20080512 21:46:19 nbsp i have seen Zuni in the sewers!!!! and on Halloween it was scary just to see that black cat :0 Users/Yeni

20090125 18:07:48 nbsp The J St Coop has room(s) available after March 20th. Interested parties should contact us soon. peace. Users/PxlAted

20100114 00:20:54 nbsp SAVE DSC!  KEEP this great Davis Legacy alive! Users/DerekDowney

20140417 15:49:54 nbsp I lived for a couple of months at the DSC in 1989glad to see the house is still going strong.  Zuni looks like a second or third generation offspring from my two long haired black cats that I had while I was there, their names were Twelve and Thirteen. Users/lynnmichele


text:
program main
  use star
  implicit none
  call printstar(12)
  print*, "Hello World!"
  call printstar(12)
end program main

max_stars_repo_name: cibinjoseph/deb-tutorial

max_issues_repo_name: cibinjoseph/deb-tutorial

max_forks_repo_name: cibinjoseph/deb-tutorial


text:
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      BLOCK DATA BLKDAT
C=======================================================================

C   --*** BLKDAT *** (BLOT) Block data
C   --   Written by Amy Gilkey - revised 05/31/88
C   --
C   --BLKDAT contains all the COMMON areas defined for BLOT.

C=======================================================================
C                               B L O T
      PARAMETER (KLFT=1, KRGT=2, KBOT=3, KTOP=4, KNEA=5, KFAR=6)
C      --These parameters define the indices of 2D and 3D limit arrays

      include 'params.blk'
      include 'progqa.blk'
      include 'dbase.blk'
      include 'dbtitl.blk'
      include 'dbnums.blk'
      include 'dbnumgq.blk'
      include 'dbnams.blk'
      include 'legopt.blk'
      include 'times.blk'
      include 'layout.blk'
      include 'plcolr.blk'
      include 'cmap-lst.blk'
      include 'light.blk'

      common /debugc/ cdebug
      common /debugn/ idebug
      character*8 cdebug

C=======================================================================
C                        M E S H   P L O T

      PARAMETER (MSHNON=0, MSHBOR=1, MSHDIV=2, MSHSEL=3, MSHALL=4)
C      --These parameters define the mesh display (see MSHLIN of /MSHOPT/)

      include 'd3nums.blk'
      include 'deform.blk'
      include 'mshopt.blk'
      include 'views.blk'
      include 'mshlim.blk'
      include 'rotopt.blk'
      include 'cutopt.blk'
      include 'layoud.blk'
      include 'devdat.blk'
      include 'pick.blk'
      include 'sizes.blk'
      include 'linthc.blk'
      include 'sphele.blk'

C=======================================================================
C                             D E T O U R

      include 'detopt.blk'
      include 'cntr.blk'
      include 'icexct.blk'
      include 'icrnbw.blk'
      include 'etcopt.blk'
      include 'nodzom.blk'
      include 'axsplt.blk'
C=======================================================================
C                          X - Y   P L O T

      include 'xyopt.blk'
      include 'xylim.blk'
      include 'xylab.blk'
      include 'neutr.blk'

C=======================================================================
C                        P A T H L I N E

      include 'lnvars.blk'
C=======================================================================
C                             T P L O T

      include 'tpvars.blk'
C=======================================================================
C                             S P L O T

      include 'selne.blk'
      include 'spvars.blk'

C=======================================================================

      DATA IEXCON /0/
      END

ext: f

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


Module MpiExchangeColModule
  use MpiExchangeGenModule, only: serialrun
  use MpiWrapperMemory, only: ColMemoryType

  implicit none

  private

    ! -- Public functions
  public :: mpi_get_distype
  public :: mpi_get_distype_str
  public :: ColMemoryType
  public :: ciopt, n_recv, cmt_recv

  ! -- Collective receive buffer
  integer :: ciopt = 0
  integer :: n_recv
  type(ColMemoryType), dimension(:), allocatable :: cmt_recv

  save

contains

  subroutine mpi_get_distype(modelname, ldis, ldisu, ldisv)
! ******************************************************************************
! This subroutine sets the discretization type.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: LINELENGTH, LENMEMPATH, LENMODELNAME
    use SimModule, only: store_error, store_error_unit, ustop
    use MemoryHelperModule, only: split_mem_path_ff
    ! -- dummy
    character(len=*), intent(in) :: modelname
    logical, intent(out) :: ldis, ldisu, ldisv
    ! -- local
    character(len=LINELENGTH) :: errmsg
    character(len=LENMODELNAME) :: m, mh
    character(len=4) :: dis_type
    logical :: lfound
    integer :: i
! ------------------------------------------------------------------------------
    ldis  = .false.
    ldisu = .false.
    ldisv = .false.
    !
    if (serialrun) then
!    if (serialrun .or. ciopt /= 1) then
      ldis = .true.
      return
    end if
    !
    read(modelname,*) mh
    !
    lfound = .false.
    do i = 1, n_recv
      call split_mem_path_ff(cmt_recv(i)%path, m, dis_type)
      if ((m == mh) .and. (len_trim(dis_type) > 0)) then
        select case(dis_type)
          case ('DIS')
            ldis = .true.
            lfound = .true.
          case ('DISU')
            ldisu = .true.
            lfound = .true.
          case ('DISV')
            ldisv = .true.
            lfound = .true.
        end select
        if(lfound) then
          exit
        end if
      end if
    end do
    ! -- check
    if (.not.lfound) then
      write(errmsg,'(a)') 'Program error in mpi_get_distype.'
      call store_error(errmsg)
      call ustop()
    end if
    !
    ! -- return
    return
  end subroutine mpi_get_distype

  subroutine mpi_get_distype_str(modelname, disstr)
! ******************************************************************************
! This subroutine sets the discretization type.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: LINELENGTH, LENMODELNAME
    use SimModule, only: store_error, store_error_unit, ustop
    use MemoryHelperModule, only: split_mem_path_ff
    ! -- dummy
    character(len=*), intent(in) :: modelname
    character(len=*), intent(out) :: disstr
    ! -- local
    character(len=LINELENGTH) :: errmsg
    character(len=LENMODELNAME) :: m, mh
    character(len=4) :: dis_type
    logical :: lfound
    integer :: i, ios
! ------------------------------------------------------------------------------
     disstr = ''
    !
    if (serialrun) then
!    if (serialrun .or. ciopt /= 1) then
      disstr = 'DIS'
      return
    end if
    !
    read(modelname,*) mh
    !
    lfound = .false.
    do i = 1, n_recv
      call split_mem_path_ff(cmt_recv(i)%path, m, dis_type)
      if ((m == mh) .and. (len_trim(dis_type) > 0)) then
        select case(dis_type)
          case ('DIS')
            lfound = .true.
          case ('DISU')
            lfound = .true.
          case ('DISV')
            lfound = .true.
        end select
        if(lfound) then
          disstr = dis_type
          exit
        end if
      end if
    end do
    ! -- check
    if (.not.lfound) then
      write(errmsg,'(a)') 'Program error in mpi_get_distype_str.'
      call store_error(errmsg)
      call ustop()
    end if
    !
    ! -- return
    return
  end subroutine mpi_get_distype_str

end module MpiExchangeColModule


PROGRAM MonteCarlo1
  ! This program demonstrates a serial Monte Carlo method by simulating a
  ! random walk in two dimensions of 100,000 particles in 10 steps. The program
  ! outputs the distribution of the distances that the particles have travled.

  USE IFPORT

  IMPLICIT NONE

  INTEGER, PARAMETER      :: n = 100000
  INTEGER, DIMENSION(0:9) :: total

  REAL    :: pi, x, y, angle
  INTEGER :: i, step, temp

  pi = 3.1415926
  DO i = 0, 9
    total(i) = 0
  ENDDO

  CALL srand(100)
  DO i = 1, n
    x = 0.0
    y = 0.0
    DO step = 1, 10
      angle = 2.0 * pi * rand()
      x = x + cos(angle)
      y = y + sin(angle)
    ENDDO

    temp = sqrt(x**2 + y**2)
    total(temp) = total(temp) + 1
  ENDDO

  write (*,*) 'total =', total
END PROGRAM MonteCarlo1


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

C $Id: pltvwp.f,v 1.3 1993/07/19 17:06:45 gdsjaar Exp $
C $Log: pltvwp.f,v $
C Revision 1.3  1993/07/19 17:06:45  gdsjaar
C Changed hex constants back to preceding X, --needed on cray. Works
C either way on other systems.
C
c Revision 1.2  1993/07/16  17:33:23  gdsjaar
c Integer constant too big on sun, replaced it with hexadecimal notation
c
c Revision 1.1  1993/07/16  16:49:50  gdsjaar
c Changed plt to library rather than single source file.
c
C=======================================================================
      SUBROUTINE PLTVWP(PLL,PUR,N,MASK,PX,PY)
      REAL PLL(2),PUR(2)
      INTEGER MASK(*)
      REAL PX(*),PY(*)
      include 'izbit.inc'

      PUR1 = PUR(1) + .0001
      PUR2 = PUR(2) + .0001
      PLL1 = PLL(1) - .0001
      PLL2 = PLL(2) - .0001
      J = 0
      KM = 0
 2300 IF (.NOT. (J.LT.N)) GO TO 2310
      JN = MIN(N-J,32)
      J1 = J
      J = J + JN
      KM = KM + 1
      IF (MASK(KM).EQ.0) THEN
         GO TO 2300

      END IF

      DO 2320 K = 1,JN
         IF (IAND(MASK(KM),IZBIT(K)).EQ.0) THEN
            GO TO 2320

         END IF

         IF (PX(K+J1).LT.PLL1 .OR. PX(K+J1).GT.PUR1) THEN
            MASK(KM) = IAND(MASK(KM),NOT(IZBIT(K)))
            GO TO 2320

         END IF

         IF (PY(K+J1).LT.PLL2 .OR. PY(K+J1).GT.PUR2) THEN
            MASK(KM) = IAND(MASK(KM),NOT(IZBIT(K)))
            GO TO 2320

         END IF

 2320 CONTINUE
      GO TO 2300

 2310 CONTINUE
      RETURN

      END

max_stars_repo_name: smukher/seacas

max_issues_repo_name: smukher/seacas

max_forks_repo_name: smukher/seacas


text:
-makelib ies_lib/xilinx_vip -sv \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/axi4stream_vip_axi4streampc.sv" \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/axi_vip_axi4pc.sv" \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/xil_common_vip_pkg.sv" \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/axi4stream_vip_pkg.sv" \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/axi_vip_pkg.sv" \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/axi4stream_vip_if.sv" \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/axi_vip_if.sv" \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/clk_vip_if.sv" \
  "H:/Xilink/Vivado/2019.1/data/xilinx_vip/hdl/rst_vip_if.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "H:/Xilink/Vivado/2019.1/data/ip/xpm/xpm_cdc/hdl/xpm_cdc.sv" \
  "H:/Xilink/Vivado/2019.1/data/ip/xpm/xpm_fifo/hdl/xpm_fifo.sv" \
  "H:/Xilink/Vivado/2019.1/data/ip/xpm/xpm_memory/hdl/xpm_memory.sv" \
-endlib
-makelib ies_lib/xpm \
  "H:/Xilink/Vivado/2019.1/data/ip/xpm/xpm_VCOMP.vhd" \
-endlib
-makelib ies_lib/axi_infrastructure_v1_1_0 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/ec67/hdl/axi_infrastructure_v1_1_vl_rfs.v" \
-endlib
-makelib ies_lib/axi_vip_v1_1_5 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/d4a8/hdl/axi_vip_v1_1_vl_rfs.sv" \
-endlib
-makelib ies_lib/processing_system7_vip_v1_0_7 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/8c62/hdl/processing_system7_vip_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../bd/design_1/ip/design_1_processing_system7_0_0/sim/design_1_processing_system7_0_0.v" \
-endlib
-makelib ies_lib/lib_pkg_v1_0_2 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/0513/hdl/lib_pkg_v1_0_rfs.vhd" \
-endlib
-makelib ies_lib/fifo_generator_v13_2_4 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/1f5a/simulation/fifo_generator_vlog_beh.v" \
-endlib
-makelib ies_lib/fifo_generator_v13_2_4 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/1f5a/hdl/fifo_generator_v13_2_rfs.vhd" \
-endlib
-makelib ies_lib/fifo_generator_v13_2_4 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/1f5a/hdl/fifo_generator_v13_2_rfs.v" \
-endlib
-makelib ies_lib/lib_fifo_v1_0_13 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4dac/hdl/lib_fifo_v1_0_rfs.vhd" \
-endlib
-makelib ies_lib/lib_srl_fifo_v1_0_2 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/51ce/hdl/lib_srl_fifo_v1_0_rfs.vhd" \
-endlib
-makelib ies_lib/lib_cdc_v1_0_2 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/ef1e/hdl/lib_cdc_v1_0_rfs.vhd" \
-endlib
-makelib ies_lib/axi_datamover_v5_1_21 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/e644/hdl/axi_datamover_v5_1_vh_rfs.vhd" \
-endlib
-makelib ies_lib/axi_sg_v4_1_12 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/91f3/hdl/axi_sg_v4_1_rfs.vhd" \
-endlib
-makelib ies_lib/axi_dma_v7_1_20 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/260a/hdl/axi_dma_v7_1_vh_rfs.vhd" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../bd/design_1/ip/design_1_axi_dma_0_0/sim/design_1_axi_dma_0_0.vhd" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/sim/bd_afc3.v" \
-endlib
-makelib ies_lib/xlconstant_v1_1_6 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/66e7/hdl/xlconstant_v1_1_vl_rfs.v" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_0/sim/bd_afc3_one_0.v" \
-endlib
-makelib ies_lib/proc_sys_reset_v5_0_13 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/8842/hdl/proc_sys_reset_v5_0_vh_rfs.vhd" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_1/sim/bd_afc3_psr_aclk_0.vhd" \
-endlib
-makelib ies_lib/smartconnect_v1_0 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/1ddd/hdl/sc_util_v1_0_vl_rfs.sv" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/c012/hdl/sc_switchboard_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_2/sim/bd_afc3_arsw_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_3/sim/bd_afc3_rsw_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_4/sim/bd_afc3_awsw_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_5/sim/bd_afc3_wsw_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_6/sim/bd_afc3_bsw_0.sv" \
-endlib
-makelib ies_lib/smartconnect_v1_0 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/f85e/hdl/sc_mmu_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_7/sim/bd_afc3_s00mmu_0.sv" \
-endlib
-makelib ies_lib/smartconnect_v1_0 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/ca72/hdl/sc_transaction_regulator_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_8/sim/bd_afc3_s00tr_0.sv" \
-endlib
-makelib ies_lib/smartconnect_v1_0 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/7de4/hdl/sc_si_converter_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_9/sim/bd_afc3_s00sic_0.sv" \
-endlib
-makelib ies_lib/smartconnect_v1_0 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/b89e/hdl/sc_axi2sc_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_10/sim/bd_afc3_s00a2s_0.sv" \
-endlib
-makelib ies_lib/smartconnect_v1_0 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/b2d0/hdl/sc_node_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_11/sim/bd_afc3_sarn_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_12/sim/bd_afc3_srn_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_13/sim/bd_afc3_s01mmu_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_14/sim/bd_afc3_s01tr_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_15/sim/bd_afc3_s01sic_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_16/sim/bd_afc3_s01a2s_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_17/sim/bd_afc3_sawn_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_18/sim/bd_afc3_swn_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_19/sim/bd_afc3_sbn_0.sv" \
-endlib
-makelib ies_lib/smartconnect_v1_0 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/7005/hdl/sc_sc2axi_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_20/sim/bd_afc3_m00s2a_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_21/sim/bd_afc3_m00arn_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_22/sim/bd_afc3_m00rn_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_23/sim/bd_afc3_m00awn_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_24/sim/bd_afc3_m00wn_0.sv" \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_25/sim/bd_afc3_m00bn_0.sv" \
-endlib
-makelib ies_lib/smartconnect_v1_0 -sv \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/b387/hdl/sc_exit_v1_0_vl_rfs.sv" \
-endlib
-makelib ies_lib/xil_defaultlib -sv \
  "../../../bd/design_1/ip/design_1_axi_smc_0/bd_0/ip/ip_26/sim/bd_afc3_m00e_0.sv" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../bd/design_1/ip/design_1_axi_smc_0/sim/design_1_axi_smc_0.v" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../bd/design_1/ip/design_1_rst_ps7_0_100M_1/sim/design_1_rst_ps7_0_100M_1.vhd" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/convolution_netwohbi.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/convolution_netwoibs.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/convolution_netwojbC.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/convolution_netwokbM.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/convolution_netwolbW.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/convolution_netwoNgs.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/convolution_netwoYie.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/fifo_w1_d576_A.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/fifo_w1_d810_A.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/fifo_w32_d576_A.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/fifo_w32_d810_A.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/hw_convolution_2D.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/hw_convolution_2Dbkb.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/hw_convolution_2Dcud.v" \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4862/hdl/verilog/convolution_network.v" \
  "../../../bd/design_1/ip/design_1_convolution_network_0_1/sim/design_1_convolution_network_0_1.v" \
-endlib
-makelib ies_lib/generic_baseblocks_v2_1_0 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/b752/hdl/generic_baseblocks_v2_1_vl_rfs.v" \
-endlib
-makelib ies_lib/axi_data_fifo_v2_1_18 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/5b9c/hdl/axi_data_fifo_v2_1_vl_rfs.v" \
-endlib
-makelib ies_lib/axi_register_slice_v2_1_19 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/4d88/hdl/axi_register_slice_v2_1_vl_rfs.v" \
-endlib
-makelib ies_lib/axi_protocol_converter_v2_1_19 \
  "../../../../mnistVivado.srcs/sources_1/bd/design_1/ipshared/c83a/hdl/axi_protocol_converter_v2_1_vl_rfs.v" \
-endlib
-makelib ies_lib/xil_defaultlib \
  "../../../bd/design_1/ip/design_1_auto_pc_0/sim/design_1_auto_pc_0.v" \
  "../../../bd/design_1/sim/design_1.v" \
-endlib
-makelib ies_lib/xil_defaultlib \
  glbl.v
-endlib

max_stars_repo_name: brunoss/isel-aac

max_issues_repo_name: brunoss/isel-aac

max_forks_repo_name: brunoss/isel-aac


text:
! Test cshift0 for character arrays.
! { dg-do run }
program main
  implicit none
  integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3
  character (len = slen), dimension (n1, n2, n3) :: a
  integer (kind = 1) :: shift1 = 3
  integer (kind = 2) :: shift2 = 4
  integer (kind = 4) :: shift3 = 5
  integer (kind = 8) :: shift4 = 6
  integer :: i1, i2, i3

  do i3 = 1, n3
    do i2 = 1, n2
      do i1 = 1, n1
        a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3)
      end do
    end do
  end do

  call test (cshift (a, shift1, 1), int (shift1), 0, 0)
  call test (cshift (a, shift2, 2), 0, int (shift2), 0)
  call test (cshift (a, shift3, 3), 0, 0, int (shift3))
  call test (cshift (a, shift4, 3), 0, 0, int (shift4))
contains
  subroutine test (b, d1, d2, d3)
    character (len = slen), dimension (n1, n2, n3) :: b
    integer :: d1, d2, d3

    do i3 = 1, n3
      do i2 = 1, n2
        do i1 = 1, n1
          if (b (i1, i2, i3) .ne. a (mod (d1 + i1 - 1, n1) + 1, &
                                     mod (d2 + i2 - 1, n2) + 1, &
                                     mod (d3 + i3 - 1, n3) + 1)) call abort
        end do
      end do
    end do
  end subroutine test
end program main

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


! { dg-do run }
! { dg-options "-O0 -fbounds-check" }
! Tests patch for PR29371, in which the null pointer
! assignment would cause a segfault with the bounds
! check on.
!
! Contributed by Tobias Burnus <tobias.burnus@physik.fu-berlin.de>
!
program test
  implicit none
  type projector_t
    real,   pointer :: ket(:, :), bra(:, :)
  end type projector_t

  type(projector_t),pointer, dimension(:) :: p
  integer :: stat,i
  allocate(p(2),stat=stat)
  do i = 1, 2
        nullify(p(i)%bra)
        nullify(p(i)%ket)
  end do
  do i = 1, 2
        if (associated (p(i)%bra)) STOP 1
        if (associated (p(i)%ket)) STOP 2
  end do
end program


text:
      module tfpmat

      contains
      subroutine tflinkedpat(pat0,pat)
      use tfstk
      use tfcode
      use iso_c_binding
      implicit none
      type (sad_pat), target :: pat0
      type (sad_pat), pointer, intent(out):: pat
c      logical*4 rep
c      rep=.false.
      pat=>pat0
      do while(associated(pat%equiv))
        pat=>pat%equiv
c        rep=.true.
      enddo
c      if(rep .and. pat%mat .eq. 0)then
c        pat%equiv=>pat0
c        pat=>pat0
c        pat%mat=0
c        pat%value%k=ktfref
c        nullify(pat%equiv)
c      endif
      return
      end subroutine

      end module

      integer*4 function itfpmat(k,kp)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(in):: k,kp
      type (sad_pat), pointer :: pat
      type (sad_dlist), pointer :: list
      integer*4 itfpatmat,itflistmat
      itfpmat=-1
      if(ktfpatq(kp,pat))then
        itfpmat=itfpatmat(k,pat)
      elseif(ktflistq(kp,list))then
        if(ktfnonlistq(k) .and. iand(list%attr,lsimplepat) .ne. 0)then
          return
        endif
        itfpmat=itflistmat(k,list)
      elseif(tfsameq(k,kp))then
        itfpmat=1
      endif
      return
      end

      integer*4 function itflistmat1(k,listp,f)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_dlist) ,intent(inout):: listp
      logical*4 ,intent(in):: f
      integer*4 itflistmat
      if(f)then
        write(*,*)'listmat1 ',f
      endif
      itflistmat1=itflistmat(k,listp)
      return
      end

      integer*4 function itflistmat(k,listp)
      use tfstk
      use efun
      use eeval
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_descriptor) kph,ki,kc,kh,kf,k1,kp1
      type (sad_dlist) ,intent(inout):: listp
      type (sad_dlist), pointer :: lista,kl1
      integer*8 kpp,ierrorth0
      integer*4 i,itfpmat,isp3,irtc,isp1,itfseqmatseq,isp0,
     $     itfseqmatstk,iop,isp2,ic,itfconstpart,icm,
     $     np,itfseqmatstk1
      logical*4 tfconstpatternlistbodyqo,ra,tfordlessq
      itflistmat=-1
      kph=listp%head
      main: do
        if(iand(lsimplepat,listp%attr) .ne. 0)then
          if(ktfnonlistq(k,lista))then
            return
          endif
          isp0=isp
          kh=lista%head
          itflistmat=itfpmat(kh,listp%head)
          if(itflistmat .lt. 0)then
            return
          endif
          isp1=isp
          np=listp%nl
          if(tfordlessq(kh) .and. lista%nl .gt. 1)then
            iop=iordless
            do while(iop .ne. 0)
              if(ktastk(iop) .ne. ksad_loc(listp%head%k))then
                iop=itastk2(1,iop)
              else
                exit
              endif
            enddo
            if(iop .ne. 0)then
              iordless=iop
              itflistmat=min(itflistmat,
     $             itfseqmatstk(itastk(1,iop+1),itastk(2,iop+1),
     $             listp%dbody(1),np,1,ktfreallistq(listp),int8(-1)))
              if(itflistmat .lt. 0)then
                call tfresetpat(kph)
              endif
              return
            else
              kpp=sad_loc(listp%head)
            endif
            icm=isp1
            call tfgetllstkall(lista)
            if(np .eq. 0)then
              if(isp1 .lt. isp)then
                itflistmat=-1
                call tfresetpat(kph)
                isp=isp0
              else
                isp=isp1
              endif
              return
            endif
          else
            call tfgetllstkall(lista)
            if(np .eq. 0)then
              if(isp1 .lt. isp)then
                exit main
              else
                isp=isp1
              endif
              return
            endif
            if(ktfreallistq(listp))then
              if(np .ne. isp-isp1)then
                exit main
              endif
              do i=1,np
                if(ktfnonrealq(ktastk(isp1+i)) .or.
     $               ktastk(isp1+i) .ne. listp%dbody(i)%k)then
                  exit main
                endif
              enddo
              isp=isp1
              return
            elseif(tfconstpatternlistbodyqo(listp))then
              if(np .ne. isp-isp1)then
                exit main
              endif
              do i=1,np
                if(.not. tfsameq(ktastk(isp1+i),listp%dbody(i)%k))then
                  exit main
                endif
              enddo
              return
            endif
            icm=isp1
            ic=itfconstpart(listp,np,0,kc)
            loop20: do while(ic .ne. 0)
              LOOP_I: do i=icm+1,isp
                if(tfsameq(dtastk(i),kc))then
                  if(i .eq. icm+1 .and. i-isp1 .eq. ic)then
                    icm=i
                  endif
                  exit loop20
                endif
              enddo LOOP_I
              exit main
            enddo loop20
            ic=itfconstpart(listp,np,ic,kc)
          endif
          kpp=0
          isp2=isp
          if(itflistmat .ge. 0)then
            if(np .eq. icm-isp1+1)then
              itflistmat=min(itflistmat,
     $             itfseqmatstk1(icm+1,isp2,listp%dbody(np)))
            else
              itflistmat=min(0,
     $             itfseqmatstk(icm+1,isp2,listp%dbody(1),np,icm-isp1+1,
     $             ktfreallistq(listp),kpp))
            endif
          endif
          if(itflistmat .lt. 0)then
            call tfresetpat(kph)
            isp=isp0
          endif
        else
          select case (kph%k)
          case (ktfoper+mtfalt)
            if(ktfreallistq(listp))then
              if(ktfrealq(k))then
                do i=1,listp%nl
                  if(k%k .eq. listp%dbody(i)%k)then
                    itflistmat=1
                    return
                  endif
                enddo
              endif
            else
              ra=.true.
              do i=1,listp%nl
                ki=listp%dbody(i)
                if(ktfpatq(ki) .or. ktflistq(ki))then
                  ra=.false.
                endif
                itflistmat=itfpmat(k,ki)
                if(itflistmat .ge. 0)then
                  if(ra)then
                    if(i .gt. 1)then
                      listp%dbody(2:i)=listp%dbody(1:i-1)
                      listp%dbody(1)=ki
                    endif
                  endif
                  return
                endif
              enddo
            endif
          case (ktfoper+mtfpattest)
            if(listp%nl .eq. 2)then
              itflistmat=itfpmat(k,listp%dbody(1))
              if(itflistmat .ge. 0)then
                isp3=isp
                isp=isp+1
                dtastk(isp)=tfeevalref(listp%dbody(2),irtc)
                if(irtc .ne. 0)then
                  if(irtc .gt. 0 .and. ierrorprint .ne. 0)then
                    call tfreseterror
                  endif
                  itflistmat=-1
                  call tfresetpat(listp%dbody(1))
                  isp=isp3
                else
                  isp=isp+1
                  dtastk(isp)=k
                  ierrorth0=ierrorth
                  ierrorth=10
                  kf=tfefunref(isp3+1,.true.,irtc)
                  ierrorth=ierrorth0
                  isp=isp3
                  do
                    if(irtc .ne. 0)then
                      if(irtc .gt. 0 .and. ierrorprint .ne. 0)then
                        call tfreseterror
                      endif
                      exit
                    elseif(ktfnonrealq(kf) .or. kf%k .eq. 0)then
                      exit
                    endif
                    return
                  enddo
                  itflistmat=-1
                  call tfresetpat(listp%dbody(1))
                  return
                endif
              endif
            endif
          case (ktfoper+mtfrepeated,ktfoper+mtfrepeatednull)
            if(ktfsequenceq(k%k))then
              isp1=isp
              isp=isp+1
              dtastk(isp)=lista%dbody(1)
              isp2=isp
              itflistmat=itfseqmatseq(isp1+1,isp2,listp,1)
              if(itflistmat .lt. 0)then
                isp=isp1
              endif
            else
              if(k%k .eq. ktfoper+mtfnull)then
                if(kph%k .eq. ktfoper+mtfrepeatednull)then
                  itflistmat=1
                endif
              else
                kp1=listp%dbody(1)
                do
                  k1=k
                  itflistmat=itfpmat(k1,kp1)
                  if(itflistmat .lt. 0 .and. ktflistq(k1,kl1))then
                    k1=kl1%head
                    cycle
                  endif
                  exit
                enddo
              endif
            endif
          case default
            if(kph%k .eq. kxliteral)then
              if(listp%nl .eq. 0)then
                if(k%k .eq. ktfoper+mtfnull)then
                  itflistmat=1
                endif
              else
                kp1=listp%dbody(1)
                itflistmat=itfpmat(k,kp1)
              endif
              return
            endif
            listp%attr=ior(lsimplepat,listp%attr)
            cycle
          end select
        endif
        return
      enddo main
      itflistmat=-1
      call tfresetpat(kph)
      isp=isp0
      return
      end

      integer*4 function itfconstpart(list,m,n,kx)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(out):: kx
      type (sad_descriptor) ki
      type (sad_dlist) ,intent(inout):: list
      integer*4 ,intent(in):: n,m
      integer*4 i,is,n1
      itfconstpart=0
      n1=n+1
      is=list%attr
      if(iand(kallnofixedarg,is) .ne. 0)then
        return
      else
        do i=n1,m
          ki=list%dbody(i)
          if(ktfpatq(ki))then
            list%attr=ior(knofixedarg,list%attr)
          elseif(ktflistq(ki))then
            if(tfconstpatternq(ki))then
              itfconstpart=i
              kx=ki
              return
            endif
            list%attr=ior(knoconstlist,list%attr)
          else
            itfconstpart=i
            kx=ki
            return
          endif
        enddo
        if(n1 .eq. 1)then
          list%attr=ior(kallnofixedarg,list%attr)
        endif
      endif
      return
      end

      integer*4 function itfpatmat(k,pat0)
      use tfstk
      use tfcode
      use tfpmat
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_descriptor) kv1
      type (sad_pat) ,intent(in):: pat0
      type (sad_pat), pointer :: pat
      type (sad_dlist), pointer :: list
      integer*8 kav1
      integer*4 itfsinglepat,isp1,isp2,i,np,iss
      itfpatmat=-1
      call tflinkedpat(pat0,pat)
      kv1=pat%value
c      call tfdebugprint(sad_descr(pat),'patmat',1)
c      call tfdebugprint(kv1,'value:',1)
      if(pat%mat .eq. 0)then
        itfpatmat=itfsinglepat(k,pat)
c        write(*,*)'patmat-result ',itfpatmat,pat%mat
      elseif(ktfrefq(kv1,kav1) .and. kav1 .gt. 3)then
        if(ktflistq(k,list))then
          if(list%head%k .eq. ktfoper+mtfnull)then
            isp1=isp
            call tfgetllstkall(list)
            iss=int(kav1-ispbase)
            isp2=isp
            np=itastk2(1,iss)-iss
            if(isp2-isp1 .ge. np)then
              do i=1,np
                if(.not. tfsameq(dtastk(isp1+i),dtastk(iss+i)))then
                  isp=isp1
                  return
                endif
              enddo
              itfpatmat=1
            endif
          endif
        endif
      elseif(tfsameq(k,pat%value))then
        itfpatmat=1
      endif
      return
      end

      integer*4 function itfseqmatseq(isp1,isp2,kl,mp1)
      use tfstk
      implicit none
      type (sad_dlist) ,intent(inout):: kl
      integer*4 ,intent(in):: isp1,isp2,mp1
      integer*4 itfseqmatstk21
      itfseqmatseq=merge(0,
     $     itfseqmatstk21(isp1,isp2,kl%dbody(1),
     $     kl%nl,mp1,ktfreallistq(kl),i00,
     $     isp1 .gt. isp2 .and. mp1 .gt. kl%nl),
     $     isp1 .gt. isp2 .and. mp1 .gt. kl%nl)
      return
      end

c$$$      integer*4 function itfseqmat(isp10,isp20,kp,mp,mp1)
c$$$      use tfstk
c$$$      implicit none
c$$$      type (sad_descriptor) ,intent(inout):: kp(1)
c$$$      integer*4 ,intent(in):: isp10,isp20,mp,mp1
c$$$      integer*4 isp1,isp2,itfseqmatstk,itfseqmatstk1
c$$$      isp1=isp10
c$$$      isp2=isp20
c$$$      write(*,*)'seqmat ',mp,mp1,isp1,isp2
c$$$      itfseqmat=merge(0,merge(itfseqmatstk1(isp1,isp2,kp(1)),
c$$$     $     itfseqmatstk(isp1,isp2,kp,mp,mp1,.false.,i00),
c$$$     $     mp .eq. 1 .and. mp1 .eq. 1),
c$$$     $     isp1 .gt. isp2 .and. mp1 .gt. mp)
c$$$      return
c$$$      end

      integer*4 function itfseqmatstk11(isp10,isp20,kp,f)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(inout):: kp
      integer*4 ,intent(in):: isp10,isp20
      logical*4 ,intent(in):: f
      integer*4 itfseqmatstk1
      if(.not. f)then
        write(*,*)'seqmatstk11 '
      endif
      itfseqmatstk11=itfseqmatstk1(isp10,isp20,kp)
      return
      end

      integer*4 function itfseqmatstk1(isp10,isp20,kp)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(inout):: kp
      integer*4 ,intent(in):: isp10,isp20
      integer*4 isps,itfseqm,i,ispm,iop0,ispm0,mstk0
      mstk0=mstk
      ispm=isp10-1
      iop0=iordless
      ispm0=ispm
      do
c        write(*,*)'itfsqms1-1 ',isp10,isp20,ispm,isps,isp20
        i=itfseqm(isp10,isp20,kp,ispm,isps,isp20)
c        write(*,*)'itfsqms1-2 ',i
        if(i .ge. 0)then
          if(isp20 .lt. isps)then
            itfseqmatstk1=min(1,i)
          else
            itfseqmatstk1=-1
          endif
          if(itfseqmatstk1 .ge. 0)then
            return
          endif
          call tfresetpat(kp)
          if(iordless .ne. iop0)then
            ispm=ispm0
            cycle
          endif
        else
          iordless=iop0
        endif
        exit
      enddo
      mstk=mstk0
      itfseqmatstk1=-1
      return
      end

      recursive integer*4 function
     $     itfseqmatstk21(isp10,isp20,kp0,map,mp1,realp,kpp,f)
     $      result(ix)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(inout):: kp0(1)
      integer*8 ,intent(in):: kpp
      integer*4 ,intent(in):: isp10,isp20,map,mp1
      logical*4 ,intent(in):: realp,f
      integer*4 itfseqmatstk
      if(f)then
        write(*,*)'seqmatstk21 '
      endif
      ix=itfseqmatstk(isp10,isp20,kp0,map,mp1,realp,kpp)
      return
      end

      recursive integer*4 function
     $     itfseqmatstk(isp10,isp20,kp0,map,mp1,realp,kpp)
     $      result(ix)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(inout):: kp0(1)
      type (sad_descriptor) kp,k1
      integer*8 ,intent(in):: kpp
      integer*4 ,intent(in):: isp10,isp20,map,mp1
      integer*4 isps,itfseqm,i,ispf,
     $     np,ispp,mop,iop,iop0,np0,npd,npdi,
     $     isp1a,isp2a,ispt,mstk0,itfseqmatstk1
      logical*4 ,intent(in):: realp
      mop=0
      if(mp1 .gt. map)then
        ix=merge(1,-1,isp20 .lt. isp10)
        return
      endif
      kp%k=merge(i00,kp0(mp1)%k,realp)
      mstk0=mstk
      ispf=isp20
c      write(*,*)'itfsqmsk-1 ',isp10,isp20,map,mp1
      if(kpp .eq. 0)then
        isp1a=isp10
        isp2a=isp20
        if(map .eq. mp1+1)then
          do while(ispf .ge. isp1a-1)
            iop0=iordless
            ispt=ispf
            do
              i=itfseqm(isp1a,isp2a,kp,ispf,isps,ispt)
              if(i .ge. 0)then
                ix=min(i,itfseqmatstk1(isps,isp2a,kp0(map)))
                if(ix .ge. 0)then
                  return
                endif
                call tfresetpat(kp)
                if(iordless .ne. iop0)then
                  ispf=ispt
                  cycle
                endif
              else
                iordless=iop0
              endif
              exit
            enddo
          enddo
        elseif(map .ne. mp1)then
          do while(ispf .ge. isp1a-1)
            iop0=iordless
            ispt=ispf
            do
              i=itfseqm(isp1a,isp2a,kp,ispf,isps,ispt)
              if(i .ge. 0)then
                ix=min(i,itfseqmatstk(isps,isp2a,
     $               kp0,map,mp1+1,realp,i00))
                if(ix .ge. 0)then
                  return
                endif
                call tfresetpat(kp)
                if(iordless .ne. iop0)then
                  ispf=ispt
                  cycle
                endif
              else
                iordless=iop0
              endif
              exit
            enddo
          enddo
        else
          do while(ispf .ge. isp1a-1)
            iop0=iordless
            ispt=ispf
            do
              i=itfseqm(isp1a,isp2a,kp,ispf,isps,isp2a)
              if(i .ge. 0)then
                ix=merge(1,-1,isp2a .lt. isps)
                if(ix .ge. 0)then
                  return
                endif
                call tfresetpat(kp)
                if(iordless .ne. iop0)then
                  ispf=ispt
                  cycle
                endif
              else
                iordless=iop0
              endif
              exit
            enddo
          enddo
        endif
        mstk=mstk0
        ix=-1
        return
      endif
      iop=iordless
      do
        if(iop .ne. 0)then
          if(kpp .gt. 0)then
            do while(iop .ne. 0 .and. ktastk(iop) .ne. kpp)
              iop=itastk2(1,iop)
            enddo
            if(iop .eq. 0)then
              cycle
            endif
            iordless=iop
          endif
          ispf=itastk2(2,iop)
          isp1a=itastk(1,iop+1)
          isp2a=itastk(2,iop+1)
          np=itastk2(1,iop+1)
        else
          mstk=mstk-2
          iop=mstk+1
          ktastk(iop)=kpp
          itastk2(1,iop)=iordless
          itastk2(2,iop)=ispf
          itastk(1,iop+1)=isp10
          itastk(2,iop+1)=isp20
          itastk2(1,iop+1)=0
          np=0
          iordless=iop
          isp1a=isp10
          isp2a=isp20
          ispf=isp20
        endif
        exit
      enddo
      do
        do while(ispf .ge. isp1a-1)
          iop0=iordless
          ispt=ispf
          ix=-1
          do while (ix .lt. 0)
            ispt=merge(isp2a,ispf,map .eq. mp1)
            i=itfseqm(isp1a,isp2a,kp,ispf,isps,ispt)
            if(i .ge. 0)then
              if(mp1 .ge. map)then
                if(isp2a .lt. isps)then
                  ix=min(1,i)
                endif
              else
                ix=min(i,merge(itfseqmatstk1(isps,isp2a,kp0(map)),
     $               itfseqmatstk(isps,isp2a,kp0,map,mp1+1,
     $               realp,i00),map .eq. mp1+1))
              endif
              if(ix .ge. 0)then
                itastk2(2,iop)=ispf
                return
              endif
              call tfresetpat(kp)
              if(iordless .ne. iop0)then
                ispf=ispt
              else
                exit
              endif
            else
              iordless=iop0
              exit
            endif
          enddo
        enddo
        iordless=iop
        np=np+1
        npd=np
        np0=isp2a-isp1a+1
        do i=2,np0+1
          npdi=npd/i
          if(npdi*i .ne. npd)then
            mop=np0-i
            exit
          endif
          npd=npdi
        enddo
        if(mop .lt. 0)then
          mstk=mstk0
          ix=-1
          iordless=itastk2(1,iordless)
          return
        endif
        itastk2(1,iop+1)=np
        ispp=isp1a+mop
        k1=dtastk(ispp)
        dtastk(ispp)=dtastk(ispp+1)
        dtastk(ispp+1)=k1
c     call tfdebugprint(k1,'seqmatstk',1)
c     call tfdebugprint(ktastk(ispp),'<->',1)
c     write(*,*)'at ',ispp,' with ',mop,np
        ispf=isp20
      enddo
      end

      recursive integer*4 function
     $     itfseqm(isp1,isp2,kp0,ispf,isps,ispt) result(ix)
      use tfstk
      use tfcode
      use tfpmat
      use efun
      use eeval
      use iso_c_binding
      implicit none
      type (sad_descriptor) ,intent(in):: kp0
      type (sad_descriptor) kp1,kp,kd,k2,kf
      type (sad_pat), pointer :: pat,pat0
      type (sad_dlist), pointer :: listp
      integer*8 ka2,kad,ierrorth0
      integer*4 ,intent(out):: ispf,isps
      integer*4 ,intent(in):: isp1,isp2,ispt
      integer*4 itfpmat,m,iss,isp0,irtc,
     $     itfseqmatseq,itflistmat,itfsinglepat,ireppat
      integer*4 np,i
      ix=-1
      isps=0
      kp=kp0
      if(ktfpatq(kp,pat0))then
        pat=>pat0
c        call tfdebugprint(sad_descr(pat),'itfseqm-0',1)
        do while(associated(pat%equiv))
c          write(*,*)': ',ktfaddr(sad_descr(pat%equiv)),
c     $         ktftyped(sad_descr(pat%equiv))-ktfpat
c          call tfdebugprint(sad_descr(pat%equiv),'itfseqm-e',1)
          pat=>pat%equiv
        enddo
c        call tfdebugprint(sad_descr(pat),'itfseqm-1',1)
c        call tflinkedpat(pat0,pat)
        k2=pat%value
c        call tfdebugprint(sad_descr(pat),'seqm-pat',1)
c        call tfdebugprint(k2,':=',1)
        if(k2%k .ne. ktfref)then
          ispf=isp1-2
          if(ktfrefq(k2,ka2) .and. ka2 .gt. 3)then
            iss=int(ka2-ispbase)
            np=itastk2(1,iss)-iss
            m=isp1+np-1
            if(m .le. ispt)then
              do i=1,np
                if(.not. tfsameq(dtastk(iss+i),dtastk(isp1+i-1)))then
                  return
                endif
              enddo
              ix=0
              isps=m+1
            endif
          elseif(isp1 .le. isp2)then
            if(tfsameq(k2,dtastk(isp1)))then
              ix=1
              isps=isp1+1
            endif
          endif
          return
        endif
        if(pat%default%k .ne. ktfref .and. ispt .eq. isp1-1)then
          pat%value=pat%default
          ix=0
          isps=isp1
          ispf=isp1-2
          return
        endif
        kd=pat%expr
        if(.not. ktfrefq(kd,kad) .or. kad .gt. 3)then
          ix=itfseqm(isp1,isp2,kd,ispf,isps,ispt)
          if(ix .ge. 0)then
            call tfstkpat(isp1-1,isps-1,pat)
          endif
        elseif(kad .eq. 1)then
          ispf=min(ispt,isp1)-1
          if(ispt .ge. isp1 .and. isp2 .ge. isp1)then
            ix=itfsinglepat(dtastk(isp1),pat)
            isps=isp1+1
          endif
        else
          ispf=ispt-1
          isps=ispt+1
          if(ispt .eq. isp1)then
            ix=itfsinglepat(dtastk(isp1),pat)
          elseif(ispt .ge. isp1-int(kad)+2)then
            if(pat%head%k .ne. ktfref)then
              itastk2(1,isp1-1)=ispt
              ix=itfsinglepat(sad_descr(ktfref+isp1-1+ispbase),pat)
              if(ix .lt. 0)then
                return
              endif
            else
              ix=0
            endif
            call tfstkpat(isp1-1,ispt,pat)
          endif
        endif
        return
      endif
      if(ktfnonlistq(kp,listp))then
        if(isp1 .le. isp2)then
          isps=isp1+1
          if(tfsameq(dtastk(isp1),kp))then
            ix=1
          endif
c          call tfdebugprint(ktastk(isp1),'seqm',1)
c          call tfdebugprint(kp,'=?=',1)
c          write(*,*)'==> ',ix
        endif
        ispf=min(ispt,isp1)-1
        return
      else
        if(iand(lsimplepatlist,listp%attr) .eq. 0)then
          if(listp%head%k .eq. ktfoper+mtfrepeated .or.
     $         listp%head%k .eq. ktfoper+mtfrepeatednull)then
            kp1=listp%dbody(1)
            ireppat=merge(-3,-2,
     $             listp%head%k .eq. ktfoper+mtfrepeatednull)
            if(ispt .ge. isp1+ireppat+2)then
              ix=1
              ispf=ispt-1
              do i=isp1,ispt
                ix=min(ix,itfpmat(dtastk(i),kp1))
                if(ix .lt. 0)then
                  return
                endif
              enddo
              isps=ispt+1
            else
              ispf=isp1-2
            endif
            return
          elseif(listp%head%k .eq. ktfoper+mtfpattest)then
            kp1=listp%dbody(1)
            ix=itfseqm(isp1,isp2,kp1,ispf,isps,ispt)
            if(ix .lt. 0)then
              return
            endif
            isp0=isp
            call tfevalstk(listp%dbody(2),.true.,irtc)
            do
              if(irtc .ne. 0)then
                if(irtc .gt. 0 .and. ierrorprint .ne. 0)then
                  call tfreseterror
                endif
                isp=isp0
                exit
              endif
              ktastk(isp+1:isp+isps-isp1)=ktastk(isp1:isps-1)
              isp=isp+isps-isp1
              ierrorth0=ierrorth
              ierrorth=10
              kf=tfefunref(isp0+1,.true.,irtc)
              ierrorth=ierrorth0
              isp=isp0
              if(irtc .ne. 0)then
                if(irtc .gt. 0 .and. ierrorprint .ne. 0)then
                  call tfreseterror
                endif
                exit
              elseif(ktfnonrealq(kf) .or. kf%k .eq. 0)then
                exit
              endif
              return
            enddo
            ix=-1
            ispf=ispt-1
            call tfresetpat(kp1)
            return
          else
            listp%attr=ior(lsimplepatlist,listp%attr)
          endif
        else
          listp%attr=ior(lsimplepatlist,listp%attr)
        endif
        if(isp1 .le. isp2)then
          isps=isp1+1
          if(listp%head%k .eq. ktfoper+mtfnull)then
            m=isp1+listp%nl-1
            if(m .le. ispt)then
              ix=itfseqmatseq(isp1,m,listp,1)
              isps=m+1
            endif
          else
            ix=merge(-1,itflistmat(dtastk(isp1),listp),
     $           ktfnonlistq(ktastk(isp1)) .and.
     $           iand(lsimplepat,listp%attr) .ne. 0)
          endif
        elseif(listp%head%k .eq. ktfoper+mtfnull .and.
     $         listp%nl .eq. 0)then
          ix=0
          isps=isp1
          return
        endif
        ispf=isp1-2
        return
      endif
      end

      integer*4 function itfsinglepat(k,pat)
      use tfstk
      use tfcode
      use eeval
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_descriptor) kx,ke,k1,kv,kh
      type (sad_pat) ,intent(inout):: pat
      type (sad_pat), pointer :: pata
      integer*8 kax,ka,ka1
      integer*4 isp3,irtc,isp1,itfpmat,i
      itfsinglepat=-1
      kx=pat%expr
      if(ktfrefq(kx,kax))then
        if(pat%head%k .ne. ktfref)then
          isp3=isp
          kv=tfeevalref(pat%head,irtc)
          isp=isp3
          if(irtc .ne. 0)then
            if(irtc .gt. 0 .and. ierrorprint .ne. 0)then
              call tfreseterror
            endif
            return
          endif
          if(ktfrefq(k,ka) .and. kax .gt. 1)then
            ka=ka-ispbase
            isp1=itastk2(1,ka)
            do i=int(ka)+1,isp1
              call tfhead(dtastk(i),kh)
              if(.not. tfsameq(kh,kv))then
                return
              endif
            enddo
          else
            call tfhead(k,kh)
            if(.not. tfsameq(kh,kv))then
              return
            endif
          endif
        endif
        if(ktfpatq(k,pata))then
          k1=pata%expr
          if(ktfrefq(k1,ka1) .and. ka1 .le. 3 .and.
     $         ka1 .gt. kax)then
            return
          endif
        endif
      elseif(ktfpatq(k))then
        itfsinglepat=itfpmat(k,kx)
        if(itfsinglepat .lt. 0)then
          return
        endif
      else
        isp3=isp
        ke=tfeevalref(kx,irtc)
        isp=isp3
        if(irtc .ne. 0)then
          if(irtc .gt. 0 .and. ierrorprint .ne. 0)then
            call tfreseterror
          endif
          return
        endif
        itfsinglepat=itfpmat(k,ke)
        if(itfsinglepat .lt. 0)then
          return
        endif
      endif
      itfsinglepat=0
      if(pat%sym%loc .ne. 0)then
        pat%mat=1
        pat%value=k
c        call tfdebugprint(sad_descr(pat),'singlepat',1)
c        call tfdebugprint(k,':=',1)
c        write(*,*)'at ',sad_loc(pat%value)
      endif
      return
      end

      subroutine tfstkpat(isp1,isp2,pat)
      use tfstk
      use tfcode
      implicit none
      type (sad_pat) ,intent(inout):: pat
      integer*4 ,intent(in):: isp1,isp2
      if(pat%sym%loc .ne. 0)then
        pat%mat=1
        if(isp1 .ge. isp2)then
          pat%value=dxnull
        elseif(isp2 .eq. isp1+1)then
          pat%value=dtastk(isp2)
c          call tfdebugprint(sad_descr(pat),'stkstk',1)
c          call tfdebugprint(ktastk(isp),'stkstk',1)
c          write(*,*)'at ',sad_loc(pat%value)
        else
          pat%value%k=ktfref+isp1+ispbase
          itastk2(1,isp1)=isp2
        endif
      endif
      return
      end

      integer*4 function itfpmatc(k,kp)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_descriptor) ,intent(inout):: kp
      type (sad_pat), pointer :: pat
      type (sad_dlist), pointer :: klp
      integer*4 mstk0,itfpatmat,iop,isp0,itfpmatcl
      if(ktflistq(kp,klp))then
        itfpmatc=itfpmatcl(k,klp)
      elseif(ktfpatq(kp,pat))then
        iop=iordless
        iordless=0
        isp0=isp
        mstk0=mstk
        call tfinitpat(isp0,kp)
        isp=isp0
        itfpmatc=itfpatmat(k,pat)
        call tfresetpat(kp)
        mstk=mstk0
        isp=isp0
        iordless=iop
      else
        itfpmatc=merge(1,-1,tfsameq(k,kp))
      endif
      return
      end

      integer*4 function itfpmatcl(k,klp)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_dlist) ,intent(inout):: klp
      integer*4 mstk0,itflistmat,iop,isp0
      if(ktfnonlistq(k) .and. iand(klp%attr,lsimplepat) .ne. 0)then
        itfpmatcl=-1
        return
      endif
      iop=iordless
      iordless=0
      mstk0=mstk
      isp0=isp
      if(iand(klp%attr,lnopatlist) .eq. 0)then
        call tfinitpatlist(isp0,klp)
        isp=isp0
        itfpmatcl=itflistmat(k,klp)
        call tfresetpatlist(klp)
      else
        itfpmatcl=itflistmat(k,klp)
      endif
      mstk=mstk0
      isp=isp0
      iordless=iop
      return
      end

      recursive subroutine tfunsetpat(k)
      use tfstk
      use tfcode
      use iso_c_binding
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_pat), pointer :: pat
      type (sad_dlist), pointer :: klp
      if(ktflistq(k,klp))then
        call tfunsetpatlist(klp)
      elseif(ktfpatq(k,pat))then
c        do while(associated(pat%equiv))
c          pat=>pat%equiv
c          pat%mat=0
c          pat%value%k=ktfref
c          call tfunsetpat(sad_descr(pat%equiv))
c        enddo
        pat%mat=0
        pat%value%k=ktfref
        call tfunsetpat(pat%expr)
      endif
      return
      end

      recursive subroutine tfunsetpatlist(klp)
      use tfstk
      implicit none
      type (sad_dlist) ,intent(inout):: klp
      integer*4 i
      if(iand(klp%attr,lnopatlist) .ne. 0)then
        return
      endif
      call tfunsetpat(klp%head)
      if(ktfnonreallistqo(klp))then
        if(iand(klp%attr,knopatarg) .eq. 0)then
          do i=1,klp%nl
            call tfunsetpat(klp%dbody(i))
          enddo
        endif
      endif
      return
      end

      recursive subroutine tfresetpat(kp)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(inout):: kp
      type (sad_pat), pointer :: pat
      type (sad_dlist), pointer :: list
      if(ktflistq(kp,list))then
        call tfresetpatlist(list)
      elseif(ktfpatq(kp,pat))then
        call tfresetpatpat(pat)
      endif
      return
      end

      recursive subroutine tfresetpatpat(pat)
      use tfstk
      use tfcode
      use iso_c_binding
      implicit none
      type (sad_pat) ,intent(inout):: pat
      call tfresetpat(pat%expr)
      pat%mat=0
      pat%value%k=ktfref
      if(associated(pat%equiv))then
c        pat=pat%equiv
c        nullify(pat%equiv)
      endif
      return
      end

      recursive subroutine tfresetpatlist(list)
      use tfstk
      implicit none
      type (sad_dlist) ,intent(inout):: list
      integer*4 i
      if(iand(list%attr,lnopatlist) .ne. 0)then
        return
      endif
      call tfresetpat(list%head)
      if(ktfnonreallistqo(list))then
        if(iand(list%attr,knopatarg) .eq. 0)then
          do i=1,list%nl
            call tfresetpat(list%dbody(i))
          enddo
        endif
      endif
      return
      end

      recursive subroutine tfinitpat(isp0,k)
      use tfstk
      use tfcode
      use iso_c_binding
      implicit none
      type (sad_descriptor) ,intent(inout):: k
      type (sad_dlist), pointer :: kl
      type (sad_pat), pointer :: pat
      integer*8 kas
      integer*4 ,intent(in):: isp0
      integer*4 i
      if(ktflistq(k,kl))then
        call tfinitpatlist(isp0,kl)
      elseif(ktfpatq(k,pat))then
        loop10: do
          nullify(pat%equiv)
          if(pat%sym%loc .ne. 0)then
            kas=ktfaddr(pat%sym%alloc)
            do i=isp0+1,isp-1,2
              if(kas .eq. ktastk(i+1) .and.
     $             ktastk(i) .ne. k%k)then
                call loc_pat(ktfaddr(ktastk(i)),pat%equiv)
c                call tfdebugprint(sad_descr(pat%equiv),'initpat-e',1)
c                write(*,*)':',ktfaddr(ktastk(i))
                exit loop10
              endif
            enddo
            isp=isp+2
            dtastk(isp-1)=k
            ktastk(isp  )=kas
          endif
          pat%value%k=ktfref
          exit
        enddo loop10
        call tfinitpat(isp0,pat%expr)
        pat%mat=0
      endif
      return
      end

      recursive subroutine tfinitpatlist(isp0,kl)
      use tfstk
      implicit none
      type (sad_dlist) ,intent(inout):: kl
      integer*4 ,intent(in):: isp0
      integer*4 isp1,m,i
      if(iand(kl%attr,lnopatlist) .ne. 0)then
        return
      endif
      isp1=isp
      call tfinitpat(isp0,kl%head)
      if(ktfnonreallistqo(kl))then
        if(iand(kl%attr,knopatarg) .eq. 0)then
          m=kl%nl
          if(kl%head%k .eq. ktfoper+mtfpattest)then
            m=1
          endif
          do i=1,m
            call tfinitpat(isp0,kl%dbody(i))
          enddo
          if(isp .eq. isp1)then
            kl%attr=ior(kl%attr,knopatarg)
          endif
        endif
      endif
      if(isp .eq. isp1)then
        kl%attr=ior(kl%attr,lnopatlist)
      endif
      return
      end

      recursive logical*4 function tfconstpatternheadqk(k)
     $     result(lx)
      use tfstk
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_dlist), pointer :: kl
      integer*8 ka
      logical*4 tfconstpatternlistbodyqo
      lx=merge(.false.,
     $     merge(ka .ne. mtfalt .and. ka .ne. mtfrepeated .and.
     $     ka .ne. mtfrepeatednull,
     $     merge(tfconstpatternheadqk(kl%head) .and.
     $     tfconstpatternlistbodyqo(kl),
     $     merge(.not. tfsamesymbolqk(k%k,kxliteral),.true.,
     $     ktfsymbolq(k)),
     $     ktflistq(k,kl)),
     $     ktfoperq(k,ka)),
     $     ktfpatq(k))
      return
      end

      logical function tfconstpatternlistbodyqo(list)
      use tfstk
      implicit none
      type (sad_descriptor) ki
      type (sad_dlist) ,intent(inout):: list
      integer*4 i
      tfconstpatternlistbodyqo=.true.
      if(ktfnonreallistqo(list))then
        if(iand(list%attr,kconstlist) .ne. 0)then
          return
        elseif(iand(list%attr,knoconstlist) .ne. 0)then
          tfconstpatternlistbodyqo=.false.
          return
        endif
        do i=1,list%nl
          ki=list%dbody(i)
          if(ktfpatq(ki))then
            tfconstpatternlistbodyqo=.false.
          elseif(ktflistq(ki))then
            tfconstpatternlistbodyqo=tfconstpatternq(ki)
          endif
          if(.not. tfconstpatternlistbodyqo)then
            list%attr=ior(list%attr,knoconstlist)
            return
          endif
        enddo
        list%attr=ior(list%attr,kconstlist)
      endif
      return
      end

      logical*4 function tfordlessq(k)
      use tfstk
      use tfcode
      use iso_c_binding
      implicit none
      type (sad_descriptor) ,intent(in):: k
      type (sad_funtbl), pointer ::fun
      type (sad_symbol), pointer ::sym
      if(ktfoperq(k))then
        call c_f_pointer(c_loc(klist(klist(ifunbase+ktfaddrd(k))-9)),
     $       fun)
        tfordlessq=iand(iattrorderless,fun%def%sym%attr) .ne. 0
      else
        tfordlessq=merge(iand(iattrorderless,sym%attr) .ne. 0,.false.,
     $       ktfsymbolq(k,sym))
      endif
      return
      end

      subroutine itfpmatdummy
      use mackw
      return
      end

max_stars_repo_name: KatsOide/SAD

max_issues_repo_name: KatsOide/SAD

max_forks_repo_name: KatsOide/SAD


text:
! This file created from test/mpi/f77/pt2pt/rsendf.f with f77tof90
! -*- Mode: Fortran; -*-
!
!  (C) 2012 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
! This program is based on the allpair.f test from the MPICH-1 test
! (test/pt2pt/allpair.f), which in turn was inspired by a bug report from
! fsset@corelli.lerc.nasa.gov (Scott Townsend)

      program rsend
      use mpi
      integer ierr, errs, comm
      logical mtestGetIntraComm
      logical verbose
      common /flags/ verbose

      errs = 0
      verbose = .false.
!      verbose = .true.
      call MTest_Init( ierr )

      do while ( mtestGetIntraComm( comm, 2, .false. ) )
         call test_pair_rsend( comm, errs )
         call mtestFreeComm( comm )
      enddo
!
      call MTest_Finalize( errs )
!
      end
!
      subroutine test_pair_rsend( comm, errs )
      use mpi
      integer comm, errs
      integer rank, size, ierr, next, prev, tag, count, i
      integer TEST_SIZE
      parameter (TEST_SIZE=2000)
      integer status(MPI_STATUS_SIZE), requests(1)
      real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
      logical verbose
      common /flags/ verbose
!
      if (verbose) then
         print *, ' Rsend and recv'
      endif
!
!
      call mpi_comm_rank( comm, rank, ierr )
      call mpi_comm_size( comm, size, ierr )
      next = rank + 1
      if (next .ge. size) next = 0
!
      prev = rank - 1
      if (prev .lt. 0) prev = size - 1
!
      tag = 1456
      count = TEST_SIZE / 3
!
      call clear_test_data(recv_buf,TEST_SIZE)
!
      if (rank .eq. 0) then
!
         call init_test_data(send_buf,TEST_SIZE)
!
         call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, &
      &                  comm, status, ierr )
!
         call MPI_Rsend(send_buf, count, MPI_REAL, next, tag, &
      &                  comm, ierr)
!
         call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
!
         if (status(MPI_SOURCE) .ne. next) then
            print *, 'Rsend: Incorrect source, expected', next, &
      &               ', got', status(MPI_SOURCE)
            errs = errs + 1
         end if
!
         if (status(MPI_TAG) .ne. tag) then
            print *, 'Rsend: Incorrect tag, expected', tag, &
      &               ', got', status(MPI_TAG)
            errs = errs + 1
         end if
!
         call MPI_Get_count(status, MPI_REAL, i, ierr)
!
         if (i .ne. count) then
            print *, 'Rsend: Incorrect count, expected', count, &
      &               ', got', i
            errs = errs + 1
         end if
!
         call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
      &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
      &                 status, ierr)
!
         call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
      &                   'rsend and recv', errs )
!
      else if (prev .eq. 0) then
!
         call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
      &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
      &                 requests(1), ierr)
         call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, &
      &                  comm, ierr )
         call MPI_Wait( requests(1), status, ierr )
         call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
      &                   'rsend and recv', errs )
!
         call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
      &                  comm, ierr)
      end if
!
      end

max_stars_repo_name: ucd-plse/mpi-error-prop

max_issues_repo_name: ucd-plse/mpi-error-prop

max_forks_repo_name: ucd-plse/mpi-error-prop


text:
program test0202
      use convertharmonics
      implicit none

      integer(i16b) :: indet(2), detplus, detminus
      integer(i16b), allocatable :: zbasislist(:, :)
      real(rk), allocatable :: zcoefs(:, :)
      real(rk) :: zoefs
      integer :: pos
      !allocate(zbasislist(10, 2))
      !allocate(zcoefs(10, 2))

      !pos =13
      !write(*, *) sign_m(pos, detplus, detminus)
      !sign_m tested all correct

      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !Need to change neact in convertharmonics
      !1e tests
      !indet(1:2) = (/21_i16b, 0_i16b/)!Correct
      !indet(1:2) = (/0_i16b, 21_i16b/)!Correct
      !indet(1:2) = (/0_i16b, 512_i16b/)!Correct for 1 e from 1 - 512
      !indet(1:2) = (/512_i16b, 0_i16b/)!Correct

      !2e tests
      !indet(1:2) = (/3_i16b, 0_i16b/)!Correct all m=0
      !indet(1:2) = (/0_i16b, 3_i16b/)! Correct
      indet(1:2) = (/0_i16b, 24_i16b/)
      !indet(1:2) = (/0_i16b, 20_i16b/)
      call Y2Z_det(indet, 1._rk,  zbasislist, zcoefs, 0)

      deallocate(zbasislist)
      deallocate(zcoefs)

end program test0202

max_stars_repo_name: MingtongH/csfcal

max_issues_repo_name: MingtongH/csfcal

max_forks_repo_name: MingtongH/csfcal


! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

! Test resolution of type-bound generics.

module m1
  type :: t
  contains
    procedure, pass(x) :: add1 => add
    procedure, nopass :: add2 => add
    procedure :: add_real
    generic :: g => add1, add2, add_real
  end type
contains
  integer function add(x, y)
    class(t), intent(in) :: x, y
  end
  integer function add_real(x, y)
    class(t), intent(in) :: x
    real, intent(in) :: y
  end
  subroutine test1(x, y, z)
    type(t) :: x
    integer :: y
    integer :: z
    !ERROR: No specific procedure of generic 'g' matches the actual arguments
    z = x%g(y)
  end
  subroutine test2(x, y, z)
    type(t) :: x
    real :: y
    integer :: z
    !ERROR: No specific procedure of generic 'g' matches the actual arguments
    z = x%g(x, y)
  end
end


text:
Address(Secret Bay Street) is a residential street in West Davis.

 Intersecting Streets

  Chesapeake Bay Avenue
  Marina Circle
  Shelter Cove Avenue and Shelter Cove Place

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text: Thomas J Tomasi served on the City Council from 3/20/1974 to 6/20/1986.  Served as Mayor from 1978 to 1979.


text:
MODULE mo_mpi_io
  USE mpi_interface, ONLY : REAL_SIZE, INT_SIZE, MY_REAL, myid, pecount, mpiroot
  USE mpi
  IMPLICIT NONE

  INTERFACE write_hist_mpi
     MODULE PROCEDURE :: write_hist_parameters_int,     &
                         write_hist_parameters_int_1d,  &
                         write_hist_parameters_real,    &
                         write_hist_field_1d,           &
                         write_hist_field_2d,           &
                         write_hist_field_3d
  END INTERFACE write_hist_mpi

  INTERFACE read_hist_mpi
     MODULE PROCEDURE :: read_hist_parameters_int,    &
                         read_hist_parameters_int_1d, &
                         read_hist_parameters_real,   &
                         read_hist_field_1d,          &
                         read_hist_field_2d,          &
                         read_hist_field_3d
  END INTERFACE read_hist_mpi

  TYPE mpi_file_parameters
     INTEGER :: id
     INTEGER(kind=MPI_OFFSET_KIND) :: disp  ! Make sure the displacement gets updated uniquely for each mpi task
  END TYPE mpi_file_parameters

  CONTAINS

    !-------------------------------------------------------------------------
    ! SUBROUTINE CREATE_MPI_HIST: Create a new file for writing restart files
    !
    SUBROUTINE create_mpi_hist(filename,fhist)
      CHARACTER(len=*), INTENT(in) :: filename
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      INTEGER :: ierr

      CALL MPI_FILE_OPEN(MPI_COMM_WORLD, filename,           &
                         MPI_MODE_CREATE + MPI_MODE_WRONLY,  &
                         MPI_INFO_NULL, fhist%id, ierr)

      ! Initialize displacement
      fhist%disp = 0

    END SUBROUTINE create_mpi_hist

    !------------------------------------------------------------------
    ! SUBROUTINE OPEN_MPI_HIST: Open existin restart file for reading
    !
    SUBROUTINE open_mpi_hist(filename,fhist)
      CHARACTER(len=*), INTENT(in) :: filename
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      INTEGER :: ierr

      CALL MPI_FILE_OPEN(MPI_COMM_WORLD, filename, MPI_MODE_RDONLY,    &
                         MPI_INFO_NULL, fhist%id, ierr)

      ! Initialize displacement
      fhist%disp = 0

    END SUBROUTINE open_mpi_hist

    !---------------------------------------------------
    ! SUBROUTINE CLOSE_MPI_HIST: Close the restart file
    !
    SUBROUTINE close_mpi_hist(fhist)
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      INTEGER :: ierr
      CALL MPI_FILE_CLOSE(fhist%id,ierr)
    END SUBROUTINE close_mpi_hist

    !------------------------------------------------------------------------------------------------
    ! SUBROUTINE WRITE_HIST_PARAMETERS_INT: Write an individual parameter value, integer implementation
    !
    SUBROUTINE write_hist_parameters_int(var,onlyroot,fhist)
      INTEGER, INTENT(in) :: var
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      IF (onlyroot) THEN
         l_root = (myid == mpiroot)
      ELSE
         l_root = .TRUE.
      END IF

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * INT_SIZE

      IF (l_root .AND. onlyroot) &
           CALL MPI_FILE_WRITE_AT(fhist%id, disp, var, 1,    &
                                  MPI_INTEGER, MPI_STATUS_IGNORE, ierr  )

      IF (l_root .AND. .NOT. onlyroot) &
           CALL MPI_FILE_WRITE_AT_ALL(fhist%id, disp, var, 1,   &
                                      MPI_INTEGER, MPI_STATUS_IGNORE, ierr)

      ! Update displacement
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + INT_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount*INT_SIZE
      END IF

    END SUBROUTINE write_hist_parameters_int

    !------------------------------------------------------------------------------------------------
    ! SUBROUTINE WRITE_HIST_PARAMETERS_INT_1D: Write an individual parameter value, integer implementation
    !
    SUBROUTINE write_hist_parameters_int_1d(nn,var,onlyroot,fhist)
      INTEGER, INTENT(in) :: nn
      INTEGER, INTENT(in) :: var(nn)
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: lsize
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      lsize = nn

      IF (onlyroot) THEN
         l_root = (myid == mpiroot)
      ELSE
         l_root = .TRUE.
      END IF

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * lsize * INT_SIZE

      IF (l_root .AND. onlyroot) &
           CALL MPI_FILE_WRITE_AT(fhist%id, disp, var, nn,    &
                                  MPI_INTEGER, MPI_STATUS_IGNORE, ierr  )

      IF (l_root .AND. .NOT. onlyroot) &
           CALL MPI_FILE_WRITE_AT_ALL(fhist%id, disp, var, nn,   &
                                      MPI_INTEGER, MPI_STATUS_IGNORE, ierr)

      ! Update displacement
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + lsize * INT_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * lsize * INT_SIZE
      END IF

    END SUBROUTINE write_hist_parameters_int_1d

    !------------------------------------------------------------------------------------------------
    ! SUBROUTINE WRITE_HIST_PARAMETERS_REAL: Write an individual parameter value, float implementation
    !
    SUBROUTINE write_hist_parameters_real(var,onlyroot,fhist)
      REAL, INTENT(in) :: var
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      IF (onlyroot) THEN
         l_root = (myid == mpiroot)
      ELSE
         l_root = .TRUE.
      END IF

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * REAL_SIZE

      IF (l_root .AND. onlyroot) &
           CALL MPI_FILE_WRITE_AT(fhist%id, disp, var, 1,    &
                                  MY_REAL, MPI_STATUS_IGNORE, ierr )

      IF (l_root .AND. .NOT. onlyroot) &
           CALL MPI_FILE_WRITE_AT_ALL(fhist%id, disp, var, 1,   &
                                      MY_REAL, MPI_STATUS_IGNORE, ierr)

      ! Update displacement
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + REAL_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * REAL_SIZE
      END IF

    END SUBROUTINE write_hist_parameters_real

    !------------------------------------------------------------------
    ! SUBROUTINE WRITE_HIST_FIELD_1D: Write 1d vectors to restart file
    !
    SUBROUTINE write_hist_field_1d(nn,var,onlyroot,fhist)
      INTEGER, INTENT(in) :: nn
      REAL, INTENT(in) :: var(nn)
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: lsize
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      lsize = nn

      IF (onlyroot) THEN
         l_root = (myid == mpiroot)
      ELSE
         l_root = .TRUE.
      END IF

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * lsize * REAL_SIZE

      IF (l_root .AND. onlyroot) &
           CALL MPI_FILE_WRITE_AT(fhist%id, disp, var, lsize,    &
                                  MY_REAL, MPI_STATUS_IGNORE, ierr )

      IF (l_root .AND. .NOT. onlyroot) &
           CALL MPI_FILE_WRITE_AT_ALL(fhist%id, disp, var, lsize,      &
                                      MY_REAL, MPI_STATUS_IGNORE, ierr)

      ! update the displacement to a next common value (same for all processes!) depending on the total process count,
      ! and the field size
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + lsize * REAL_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * lsize * REAL_SIZE
      END IF

    END SUBROUTINE write_hist_field_1d

    !-----------------------------------------------------------------
    ! SUBROUTINE WRITE_HIST_FIELD_2D: Write 2d fields to restart file
    !
    SUBROUTINE write_hist_field_2d(n2,n3,var,onlyroot,fhist)
      INTEGER, INTENT(in) :: n2,n3
      REAL, INTENT(in) :: var(n2,n3)
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: lsize
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      lsize = n2*n3

      IF (onlyroot) THEN
         l_root = (myid == mpiroot)
      ELSE
         l_root = .TRUE.
      END IF

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * lsize * REAL_SIZE

      IF (l_root .AND. onlyroot) &
           CALL MPI_FILE_WRITE_AT(fhist%id, disp, var, lsize,    &
                                  MY_REAL, MPI_STATUS_IGNORE, ierr )

      IF (l_root .AND. .NOT. onlyroot) &
           CALL MPI_FILE_WRITE_AT_ALL(fhist%id, disp, var, lsize,     &
                                      MY_REAL, MPI_STATUS_IGNORE, ierr)

      ! update the displacement to a next common value (same for all processes!) depending on the total process count,
      ! and the field size
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + lsize * REAL_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * lsize * REAL_SIZE
      END IF

    END SUBROUTINE write_hist_field_2d

    !------------------------------------------------------------------
    ! SUBROUTINE WRITE_HIST_FIELD_3D: Write 3d fields to restart file
    !
    SUBROUTINE write_hist_field_3d(n1,n2,n3,var,onlyroot,fhist)
      INTEGER, INTENT(in) :: n1,n2,n3
      REAL, INTENT(in) :: var(n1,n2,n3)
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: lsize
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      lsize = n1*n2*n3

      IF (onlyroot) THEN
         l_root = (myid == mpiroot)
      ELSE
         l_root = .TRUE.
      END IF

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * lsize * REAL_SIZE

      IF (l_root .AND. onlyroot) &
           CALL MPI_FILE_WRITE_AT(fhist%id, disp, var, lsize,    &
                                  MY_REAL, MPI_STATUS_IGNORE, ierr )

      IF (l_root .AND. .NOT. onlyroot) &
           CALL MPI_FILE_WRITE_AT_ALL(fhist%id, disp, var, lsize,     &
                                      MY_REAL, MPI_STATUS_IGNORE, ierr)

      ! update the displacement to a next common value (same for all processes!) depending on the total process count,
      ! and the field size
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + lsize * REAL_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * lsize * REAL_SIZE
      END IF

    END SUBROUTINE write_hist_field_3d

    ! -----------------------------------------
    ! IF ONLYROOT == TRUE, DISPLACEMENTS FOR ALL PROCESSORS ARE IDENTICAL
    SUBROUTINE read_hist_parameters_int(var,onlyroot,fhist)
      INTEGER, INTENT(out) :: var
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * INT_SIZE

      CALL MPI_FILE_READ_AT_ALL(fhist%id, disp, var, 1,    &
                                MPI_INTEGER, MPI_STATUS_IGNORE, ierr  )

      ! Update displacement
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + INT_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * INT_SIZE
      END IF

    END SUBROUTINE read_hist_parameters_int

    ! -----------------------------------------
    ! IF ONLYROOT == TRUE, DISPLACEMENTS FOR ALL PROCESSORS ARE IDENTICAL
    SUBROUTINE read_hist_parameters_int_1d(nn,var,onlyroot,fhist)
      INTEGER, INTENT(in) :: nn
      INTEGER, INTENT(out) :: var(nn)
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: lsize
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      lsize = nn

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * lsize * INT_SIZE

      CALL MPI_FILE_READ_AT_ALL(fhist%id, disp, var, nn,    &
                                MPI_INTEGER, MPI_STATUS_IGNORE, ierr  )

      ! Update displacement
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + lsize * INT_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * lsize * INT_SIZE
      END IF

    END SUBROUTINE read_hist_parameters_int_1d

    ! ----------------------------------------------

    SUBROUTINE read_hist_parameters_real(var,onlyroot,fhist)
      REAL, INTENT(out) :: var
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * REAL_SIZE

      CALL MPI_FILE_READ_AT_ALL(fhist%id, disp, var, 1,    &
                                MY_REAL, MPI_STATUS_IGNORE, ierr  )

      ! Update displacement
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + REAL_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * REAL_SIZE
      END IF
    END SUBROUTINE read_hist_parameters_real

    ! -----------------------------------------------

    SUBROUTINE read_hist_field_1d(nn,var,onlyroot,fhist)
      INTEGER, INTENT(in) :: nn
      REAL, INTENT(out) :: var(nn)
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: lsize
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      lsize = nn

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * lsize * REAL_SIZE

      CALL MPI_FILE_READ_AT_ALL(fhist%id, disp, var, lsize,      &
                                MY_REAL, MPI_STATUS_IGNORE, ierr)

      ! update the displacement to a next common value (same for all processes!) depending on the total process count,
      ! and the field size
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + lsize * REAL_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * lsize * REAL_SIZE
      END IF
    END SUBROUTINE read_hist_field_1d

    ! -------------------------------------------------

    SUBROUTINE read_hist_field_2d(n2,n3,var,onlyroot,fhist)
      INTEGER, INTENT(in) :: n2,n3
      REAL, INTENT(out) :: var(n2,n3)
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: lsize
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      lsize = n2*n3

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * lsize * REAL_SIZE

      CALL MPI_FILE_READ_AT_ALL(fhist%id, disp, var, lsize,      &
                                MY_REAL, MPI_STATUS_IGNORE, ierr)

      ! update the displacement to a next common value (same for all processes!) depending on the total process count,
      ! and the field size

      IF (onlyroot) THEN
         fhist%disp = fhist%disp + lsize * REAL_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * lsize * REAL_SIZE
      END IF
    END SUBROUTINE read_hist_field_2d

    ! -------------------------------------------------

    SUBROUTINE read_hist_field_3d(n1,n2,n3,var,onlyroot,fhist)
      INTEGER, INTENT(in) :: n1,n2,n3
      REAL, INTENT(out) :: var(n1,n2,n3)
      LOGICAL, INTENT(in) :: onlyroot
      TYPE(mpi_file_parameters), INTENT(inout) :: fhist
      LOGICAL :: l_root
      INTEGER :: ierr
      INTEGER(KIND=MPI_OFFSET_KIND) :: lsize
      INTEGER(KIND=MPI_OFFSET_KIND) :: disp

      lsize = n1*n2*n3

      disp = fhist%disp
      IF (.NOT. onlyroot) &
           disp = fhist%disp + myid * lsize * REAL_SIZE

      CALL MPI_FILE_READ_AT_ALL(fhist%id, disp, var, lsize,      &
                                MY_REAL, MPI_STATUS_IGNORE, ierr)

      ! update the displacement to a next common value (same for all processes!) depending on the total process count,
      ! and the field size
      IF (onlyroot) THEN
         fhist%disp = fhist%disp + lsize * REAL_SIZE
      ELSE
         fhist%disp = fhist%disp + pecount * lsize * REAL_SIZE
      END IF
    END SUBROUTINE read_hist_field_3d

    ! --------------------------------------------------

END MODULE mo_mpi_io

max_stars_repo_name: UCLALES-SALSA/UCLALES-SALSA

max_issues_repo_name: UCLALES-SALSA/UCLALES-SALSA

max_forks_repo_name: UCLALES-SALSA/UCLALES-SALSA


text:
	SUBROUTINE ZANTEN(F)
C
C	CALCULATES SELF AND MUTUAL IMPEDANCES OF ANTENNAS
C
	COMPLEX YF,ZA,TBAR,TEMP,ZT,CUR(50),Z11,Z12,Z21,Z22
	COMMON /MATR/ YF(50,50),ZA(50,50),TBAR(50,50),TEMP(50,50),CUR
	COMMON /DESIGN/ NELEM,X(50),S(50),H(50),VEL,XL,CLT,XSPAC,XDIA,ZT
	COMMON /DIPOLES/ H1,H2,SESP4,FREQMC,Z11,Z12,Z21,Z22
	DATA TWOPI /6.2831853/
C
	W = TWOPI*F
C	PRINT*,'FREQ',F
	FREQMC = 1.E-6*F
C	DO N = 1,NELEM
C	  DO M = 1,NELEM
C	  ZA(N,M) = 0.
C	  ENDDO
C	ENDDO
	DO I = 1,NELEM-1
	  DO J = I+1,NELEM
	    SESP4 = X(J) - X(I)
	    H1 = 2.*H(I)
	    H2 = 2.*H(J)
	    CALL ESP4SR
	    ZA(I,I) = Z11
	    ZA(J,J) = Z22
C		ALTERNATE CONNECTION TO FEEDER
	    ISGN = (J-I).AND.1
	    IF(ISGN.GT.0) THEN
	      ZA(I,J) = -Z12
	      ZA(J,I) = -Z21
	    ELSE
	      ZA(I,J) = Z12
	      ZA(J,I) = Z21
	    ENDIF
C	    PRINT*,' ',ISGN,ZA(I,J)
C	    PRINT*,I,J,Z11,Z12
C	    PRINT*,I,J,Z21,Z22
	  ENDDO
	ENDDO
C	FAKE VERY LARGE IMPEDANCE
C	DO N = 1,NELEM
C	  ZA(N,N) = 1.E3
C	ENDDO
	RETURN
	END
	FUNCTION AGAIN(F,THETA,PHI)
C
C	CALCULATES GAIN OF SYSTEM IN DIRECTION THETA,PHI AT FREQ. F
C	THETA AND PHI ARE IN DEGREES
C	THETA IS MEASURED FROM THE WIRE AXIS DIRECTION, PHI FROM DIRECTION
C	OF ANTENNA RADIATION AXIS, A WIERD CONVENTION, BUT APPARENTLY USUAL IN
C	ANTENNA CALCULATIONS
C
	COMPLEX YF,ZA,TBAR,TEMP,ZT,AGAIN,E,B,CUR(50)
	COMMON /MATR/ YF(50,50),ZA(50,50),TBAR(50,50),TEMP(50,50),CUR
	COMMON /DESIGN/ NELEM,X(50),S(50),H(50),VEL,XL,CLT,XSPAC,XDIA,ZT
	DATA TWOPI /6.2831853/
C
	W = TWOPI*F
	XK = W/CLT
C
C	DISTANCES ARE MEASURED FROM THE CENTER OF THE SHORTEST ELEMENT
C	THE POSITIVE DIRECTION OF CURRENT IS OUT OF THE POSITIVE SIDE OF
C	THE FEEDER, HENCE MUTUAL IMPEDANCE IS REVERSED.
C
C	CALCULATE ANGLE ANTENNA RADIATION AXIS TO VIEW DIRECTION
C	RADIATION AXIS IS  X DIRECTION
C	X(N) WAS POSITIVE, BUT IS COUNTED NEGATIVE IN THIS SYSTEM
C	INCREASING /X/ MEANS PHASE DELAY, NEGATIVE PHASE SHIFT
C
	SINTH = SIND(THETA)
	COSTH = COSD(THETA)
	COSAXD = SINTH*COSD(PHI)
	SINAXD = SQRT(1. - COSAXD**2)
C
	E = CMPLX(0.,0.)
	B = CMPLX(0.,0.)
	SG = 1.
	DO N = 1,NELEM
	  HKN = XK*H(N)
	  DPHASE = -X(N)*XK*COSAXD
	  IF(SINTH.NE.0..AND.SIN(HKN).NE.0.)
     1	  E = E + SG*CUR(N)*((COS(HKN*COSTH) - COS(HKN))/SIN(HKN))*
     1	  CEXP(CMPLX(0.,DPHASE))/SINTH
	  SG = -SG
	ENDDO
	AGAIN = E*CONJG(E)
	RETURN
	END

ext: for


text:
subroutine head(x,y)
  double precision :: x
  double precision :: y

  y=tan(x)

end subroutine

max_stars_repo_name: haiwangcat/ROSE

max_issues_repo_name: haiwangcat/ROSE

max_forks_repo_name: haiwangcat/ROSE


text:
      program t
      type x
      integer::i=1
      end type x
      type(x)::y
      print '(i0)',y%i
      end program t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
wiki:WikiPedia:Credit unions are the notforprofit financial cooperatives that offer the same services as banks such as checking accounts and savings accounts. They have the same governmentbacked guarantee on deposits up to $250,000.

With Credit Unions, the members are the owners. At banks, profits go to shareholders or owners. Since credit unions are notforprofit the money earned is returned to the members in the form of lower fees, better loan rates, etc. Some credit unions do have requirements for membership such as residing or working in the county.

If you are a student or resident of Yolo County, you are eligible to join any of the credit unions in Davis.

 Credit Unions vs. Banks

Credit unions are insured by the NCUA (National Credit Union Administration). This insurance is just like the FDIC insurance for banks. Your money is just as safe at a credit union as at a bank.

Banks are forprofit companies who are motivated to maximize the profits they can make off of depositors to give to their shareholders and executives. This is often achieved through fees and other methods. These methods are documented and mailed to you on an annual basis, but most banks realize that customers usually dont take the time to read through the documents.

Credit unions are notforprofit cooperatives which are owned by the members. Credit unions are generally democratic institutions, with a board of directors elected by member depositors, while Banks are generally corporate institutions which answer to a board of directors elected by shareholders. Credit unions often are able to offer lower loan rates to their members than banks due to the fact that credit unions are notforprofit. Locally based credit unions are also a good way to employ local people to help the local economy. Of course, when choosing whether to go with a bank or credit union, each individual needs to decide which institution will give them better deals.

Moving your money away from banks with excessive fees can save you a great deal of money in the long run. For example, many of the credit unions in Davis offer Free Checking accounts with no monthly fees and some even offer free checks. If your bank charges you a $10 monthly fee, it can add up to $120 per year.

 Credit Unions in Davis

  Golden 1 Credit Union  First box of checks free with new student checking accounts,  no minimum balance, no monthly fee, free online bill pay. You can scan and deposit checks online from a computer with a scanner for free.
  Travis Credit Union
  USE Credit Union University and State Employees Credit Union  1 free overdraft/year, free online bill pay, no minimum balance or monthly fee. You can scan and deposit checks online from a computer with a scanner for free.
  Yolo Federal Credit Union Largest number of surcharge free ATMs: US Bank ATMs, MoneyPass, & COOP ATMs (credit union ATMs), free bill pay, free student checking account and echecking account available

 Credit Union ATMs and Service

All of the credit unions in Davis are part of the http://www.coopfs.org/b2chomepage/ COOP ATM network, where you can use your credit union ATM card without a fee. There are over 28,000 COOP ATMs across the country, which is more than any other bank. Bank of America for example, only has 18,000 ATMs. COOP ATMs are in every state, while most banks only have ATMs in a limited number of states.

Credit Unions have many advantages over banks in that credit union membership gives you access to ATMs in all 50 states. You can bank anywhere.

Some credit unions are part of the CU Service Center network. That means that you can walk into any participating credit union branch in this network and deposit cash or withdraw cash for free. USE Credit Union and Golden 1 are members of this network. That means you have a network of thousands of branches to do banking in every state.

  Also see ATMs, banks, or perhaps youre interested in Foreign Currency Exchange.


text:
      program equiv05

C     The equivalence chain is not consistent

      real t(3)
      common /foo/ a, b, c
      equivalence (t(1),a), (t(2),c)

      end


text:
      SUBROUTINE QUIKVIS5A2D(ITARG,IDTARG,TARGNAMES,KTARGTYP,TARGPARM)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE IS PART OF THE QUIKVIS PROGRAM.  IT IS THE DRIVER FOR
C THE OUTPUT ROUTINE QUIKVIS5A2D1 THAT GIVES TARGET AVAILABILITY INFO
C FOR INDIVIDUALLY SPECIFIED TARGETS.
C
C
C VARIABLE      DIM       TYPE I/O DESCRIPTION
C --------      ---       ---- --- -----------
C
C ITARG          1         I*4  I  INDEX OF THE TARGET FOR WHICH OUTPUT
C                                  IS TO BE GENERATED.
C
C IDTARG      MAXTARGS     I*4  I  DESCRIBED IN QUIKVIS(=MAIN) PROLOGUE.
C
C TARGNAMES   MAXTARGS    CH*16 I  DESCRIBED IN QUIKVIS(=MAIN) PROLOGUE.
C
C KTARGTYP    MAXTARGS     I*4  I  DESCRIBED IN QUIKVIS(=MAIN) PROLOGUE.
C
C TARGPARM NPARMS,MAXTARGS R*8  I  DESCRIBED IN QUIKVIS(=MAIN) PROLOGUE.
C
C***********************************************************************
C
C BY C PETRUZZO/GFSC/742.   2/86.
C       MODIFIED....
C
C***********************************************************************
C
      INCLUDE 'QUIKVIS.INC'
C
      CHARACTER*16 TARGNAMES(MAXTARGS)
      INTEGER*4 IDTARG(MAXTARGS)
      REAL*8 TARGPARM(NPARMS,MAXTARGS)
      INTEGER*4 KTARGTYP(MAXTARGS)
C
C
C GENERATE THE OUTPUT TABLE.  THERE ARE NUMTIMES COLUMNS IN THE TABLE,
C BUT ONLY 30 COLUMNS WILL FIT ON A PAGE.  IF NUMTIMES>30, WE NEED
C SUBTABLES.  SUB-TABLES CONTAIN 30 COLUMNS EACH AND SUBTABLE COLUMNS
C OVERLAP SO THAT THE LAST 5 COLUMNS ON ONE IS THE FIRST 5 ON THE NEXT.
C
      ITIME1 = 1
      ITIME2 = 0
C
      DO WHILE (ITIME2.LT.NUMTIMES)
C
        ITIME2 = MIN( (ITIME1+29),NUMTIMES )
C
        CALL QUIKVIS5A2D1(ITIME1,ITIME2,
     *       ITARG,IDTARG,TARGNAMES,KTARGTYP,TARGPARM)
C
        ITIME1 = ITIME2 - 4    ! THIS CAUSES THE OVERLAP
C
        END DO
C
C
      RETURN
C
C***********************************************************************
C
C
C**** INITIALIZATION CALL. PUT GLOBAL PARAMETER VALUES INTO THIS
C     ROUTINE'S LOCAL VARIABLES.
C
      ENTRY QVINIT5A2D
C
      CALL QUIKVIS999(-1,R8DATA,I4DATA,L4DATA)
      RETURN
C
C***********************************************************************
C
C
      END