text:
!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine mpcadd(nodedep,is,ie,nboun,ipompc,nodempc,
     &  coefmpc,nmpc,nmpc_,mpcfree,orab,ikboun,ikmpc,ilmpc,co,labmpc,
     &  label,nodeind,iorientation)
!
!     generates an equality MPC between node "nodedep" (dependent) and
!     node "nodeind" (independent), both at the same position,
!     in orientation system "iorientation" for local degrees of
!     freedom "is" up to "ie".
!
      implicit none
!
      character*20 labmpc(*),label
!
      integer nodedep,is,ie,nboun,i,j,ipompc(*),nodempc(3,*),nmpc,nmpc_,
     &  mpcfree,ikboun(*),ikmpc(*),ilmpc(*),idof,number,id,
     &  mpcfreeold,three,kflag,iy(3),inumber,nodeind,iorientation
!
      real*8 coefmpc(*),a(3,3),co(3,*),orab(7,*),dx(3),p(3)
!
      loop: do i=is,ie
!
         if(iorientation.eq.0) then
!
!        no transformation applies: simple SPC
!
            idof=8*(nodedep-1)+i
            call nident(ikboun,idof,nboun,id)
            if(id.gt.0) then
               if(ikboun(id).eq.idof) then
                  cycle loop
               endif
            endif
            call nident(ikmpc,idof,nmpc,id)
            if(id.ne.0) then
               if(ikmpc(id).eq.idof) cycle loop
            endif
!
!           new MPC
!
            nmpc=nmpc+1
            if(nmpc.gt.nmpc_) then
               write(*,*) '*ERROR in mpcadd: increase nmpc_'
               call exit(201)
            endif
            labmpc(nmpc)=label
            ipompc(nmpc)=mpcfree
            do j=nmpc,id+2,-1
               ikmpc(j)=ikmpc(j-1)
               ilmpc(j)=ilmpc(j-1)
            enddo
            ikmpc(id+1)=idof
            ilmpc(id+1)=nmpc
!
            nodempc(1,mpcfree)=nodedep
            nodempc(2,mpcfree)=i
            coefmpc(mpcfree)=1.d0
            mpcfree=nodempc(3,mpcfree)
            if(mpcfree.eq.0) then
               write(*,*) '*ERROR in mpcadd: increase memmpc_'
               call exit(201)
            endif
!
            nodempc(1,mpcfree)=nodeind
            nodempc(2,mpcfree)=i
            coefmpc(mpcfree)=-1.d0
            mpcfreeold=mpcfree
            mpcfree=nodempc(3,mpcfree)
            if(mpcfree.eq.0) then
               write(*,*) '*ERROR in mpcadd: increase memmpc_'
               call exit(201)
            endif
            nodempc(3,mpcfreeold)=0
!
         else
!
!        transformation applies
!
            do j=1,3
               p(j)=co(j,nodedep)
            enddo
            call transformatrix(orab(1,iorientation),p,a)
!
!           new mpc
!
            iy(1)=1
            iy(2)=2
            iy(3)=3
            dx(1)=dabs(a(1,i))
            dx(2)=dabs(a(2,i))
            dx(3)=dabs(a(3,i))
            three=3
            kflag=-2
            call dsort(dx,iy,three,kflag)
            do inumber=1,3
               number=iy(inumber)
               idof=8*(nodedep-1)+number
               call nident(ikmpc,idof,nmpc,id)
               if(id.ne.0) then
                  if(ikmpc(id).eq.idof) cycle
               endif
               if(dabs(a(number,i)).lt.1.d-5) cycle
               nmpc=nmpc+1
               if(nmpc.gt.nmpc_) then
                  write(*,*) '*ERROR in mpcadd: increase nmpc_'
                  call exit(201)
               endif
               labmpc(nmpc)=label
               ipompc(nmpc)=mpcfree
               do j=nmpc,id+2,-1
                  ikmpc(j)=ikmpc(j-1)
                  ilmpc(j)=ilmpc(j-1)
               enddo
               ikmpc(id+1)=idof
               ilmpc(id+1)=nmpc
               exit
            enddo
!
!           check whether a dependent term was found; if none was
!           found this can be due to the fact that:
!           - all dofs were used by other MPC's
!           - the MPC coefficients were too small
!           - or a combination of both
!
            if(inumber.gt.3) cycle
!
            inumber=inumber-1
            do j=1,3
               inumber=inumber+1
               if(inumber.gt.3) inumber=1
               number=iy(inumber)
               if(dabs(a(number,i)).lt.1.d-30) cycle
!
               nodempc(1,mpcfree)=nodedep
               nodempc(2,mpcfree)=number
               coefmpc(mpcfree)=a(number,i)
               mpcfree=nodempc(3,mpcfree)
               if(mpcfree.eq.0) then
                  write(*,*) '*ERROR in mpcadd: increase memmpc_'
                  call exit(201)
               endif
!
               nodempc(1,mpcfree)=nodeind
               nodempc(2,mpcfree)=number
               coefmpc(mpcfree)=-a(number,i)
               mpcfreeold=mpcfree
               mpcfree=nodempc(3,mpcfree)
               if(mpcfree.eq.0) then
                  write(*,*) '*ERROR in mpcadd: increase memmpc_'
                  call exit(201)
               endif
            enddo
!
            nodempc(3,mpcfreeold)=0
         endif
      enddo loop
!
      return
      end

max_stars_repo_name: alleindrach/calculix-desktop

max_issues_repo_name: alleindrach/calculix-desktop

max_forks_repo_name: alleindrach/calculix-desktop


text:
!*robodoc*u* tests/testAAB
!  NAME
!    testAAB
!  SYNOPSIS

!$Id: testAAB.f90 529 2018-03-26 11:25:45Z mexas $

program testAAB

!  PURPOSE
!    Checking: cgca_as, cgca_ds, cgca_swci
!  DESCRIPTION
!    Writing all coarrays to a file in order, as if it were a single
!    large 3D array (super array).
!  AUTHOR
!    Anton Shterenlikht
!  NOTES
!    The program must be called with 2 command line arguments,
!    both positive integers. These are codimensions along 1 and 2.
!    The number of images must be such that
!    codimension3 = num_images()/( codimension1 * codimension3 )
!    is a positive integer. Example:
!      cafrun -np 16 ./testAAB.x 2 2      ! OpenCoarrays
!    or
!      ./testAAB.x 2 2                    ! Intel, Cray
!    which will make the third codimension equal to 16/(2*2)=4.
!  COPYRIGHT
!    See LICENSE
!  USES
!    cgca testaux
!  USED BY
!    Part of CGPACK test suite
!  SOURCE

use testaux

implicit none

 integer(kind=idef),parameter :: size1=10, size2=10, size3=10
 integer(kind=idef) :: nimages
 integer(kind=idef) :: codim(3)[*]
 integer(kind=iarr),allocatable :: space1(:,:,:,:)[:,:,:]
logical(kind=ldef) :: image1

!*********************************************************************72
! first executable statement

nimages=num_images()
image1 = .false.
if (this_image() .eq. 1) image1 = .true.

! do a check on image 1
if (image1) then
 call getcodim(nimages,codim)
 ! print a banner
 call banner("AAB")
 ! print the parameter values
 call cgca_pdmp
 write (*,'(a,i0,a)') "running on ", nimages, " images in a 3D grid"
 write (*,*) "codim:", codim
end if

sync all

if (image1) then
  write (*,*) "cgca kinds:"
  write (*,*) "default integer:", idef
  write (*,*) "coarray integer:", iarr
  write (*,*) "default logical:", ldef
end if

codim(:) = codim(:)[1]

sync all

! implicit sync all inside
call cgca_as( 1, size1, 1, size2, 1, size3, 1, codim(1), 1, codim(2),  &
              1, 2, space1 )

if (allocated(space1)) then
  write (*,'(a,i0,a)')"Image:",this_image(), " space1 allocated"
  write (*,'(a,i0,a,3(i0,tr1),a)')                                     &
    "Image: ",this_image()," is ",this_image(space1)," in the grid"
end if

space1( :, :, :, cgca_state_type_grain ) = int(this_image(), kind=iarr)
space1( :, :, :, cgca_state_type_frac ) = 0_iarr

sync all

if ( this_image() .eq. 1 )                                             &
  write (*,*) "coarrays defined, calling cgca_swci"

call cgca_swci( space1, cgca_state_type_grain, 10, 'z.raw' )

call cgca_ds(space1)

if ( .not. allocated(space1) )                                         &
  write (*,'(a,i0,a)')"Image:",this_image(), " space1 not allocated"

end program testAAB

!*roboend*

max_stars_repo_name: lcebaman/casup

max_issues_repo_name: lcebaman/casup

max_forks_repo_name: lcebaman/casup


text:
/*****************************************************************************
 * mor1kx_soc_alt_uvm_test_base.f
 *****************************************************************************/

+UVM_TESTNAME=mor1kx_soc_alt_uvm_test_base

ext: f


text:
C Copyright(C) 2009 Sandia Corporation. Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C 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     * Neither the name of Sandia Corporation 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=======================================================================
      SUBROUTINE HIDEDG (HIDEF, HIDENP, LENF, NLNKE, NLNKF, LINKF,
     &   NOTSEL, IELBST, IEDSET, NEDGES, NREF, LREF, MREF,
     *  ISBACK, NAMELB)
C=======================================================================

C   --*** HIDEDG *** (MESH) Identify 3D lines on edge of visible mesh
C   --   Written by Amy Gilkey - revised 02/26/88
C   --
C   --HIDEDG finds all lines that may make up the visible edge of the mesh.
C   --"Edges" are lines of partially visible faces or lines of
C   --totally visible faces which have no matching edge.
C   --
C   --Parameters:
C   --   HIDEF(i) - IN - true iff face i is hidden
C   --   HIDENP - IN - node status (as in HIDDEN)
C   --   LENF - IN - the cumulative face counts by element block
C   --   NLNKE - IN - the number of nodes per element
C   --   NLNKF - IN - the number of nodes per face
C   --   LINKF - IN - the connectivity for all faces
C   --   NOTSEL - IN - true iff faces with selected element blocks
C   --      are not needed
C   --   IELBST - IN - the element block status (>0 if selected)
C   --   IEDSET - OUT - the edge line set; (0) = face defining edge
C   --   NEDGES - OUT - the number of lines in the edge set
C   --   NREF - SCRATCH - the number of references to a node in the edge set;
C   --      length = NUMNPF
C   --   LREF - SCRATCH - the last edge set index of a node in the edge set;
C   --      length = NUMNPF
C   --
C   --Common Variables:
C   --   Uses NELBLK of /DBNUMS/
C   --   Uses NUMNPF of /D3NUMS/

      PARAMETER (KFVIS=0, KFNODH=10, KFPOUT=20, KFOUT=90, KFAWAY=100)
      PARAMETER (KNVIS=0, KNFOVR=10, KNHID=100)

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

      include 'dbnums.blk'
      COMMON /D3NUMS/ IS3DIM, NNPSUR, NUMNPF, LLNSET
      LOGICAL IS3DIM

      INTEGER HIDEF(*)
      INTEGER HIDENP(*)
      INTEGER LENF(0:NELBLK)
      INTEGER NLNKE(NELBLK)
      INTEGER NLNKF(NELBLK)
      INTEGER LINKF(*)
      LOGICAL NOTSEL
      INTEGER IELBST(NELBLK)
      INTEGER IEDSET(0:2,*)
      INTEGER NREF(NUMNPF), LREF(NUMNPF), MREF(NUMNPF)
      LOGICAL ISBACK(NUMNPF)
      CHARACTER*(*) NAMELB(*)

      LOGICAL ANYBRI, ANYSHE

      ANYBRI = .FALSE.
      ANYSHE = .FALSE.
      DO 100 IELB = 1, NELBLK
         IF (NLNKE(IELB) .GT. 4) ANYBRI = .TRUE.
         IF (NAMELB(IELB)(:3) .EQ. 'TET') ANYBRI = .TRUE.
         IF (NLNKE(IELB) .EQ. 4 .AND. NAMELB(IELB)(:3) .NE. 'TET')
     $        ANYSHE = .TRUE.
  100 CONTINUE

      CALL INIINT (NUMNPF, 0, LREF)

      IF (.NOT. ANYBRI) GOTO 200

C   --Mark nodes in faces that point away

      CALL INILOG (NUMNPF, .FALSE., ISBACK)

      DO 130 IELB = 1, NELBLK
         IF (NLNKE(IELB) .GT. 4 .OR. NAMELB(IELB)(:3) .eq. 'TET') THEN
            IXL0 = IDBLNK (IELB, 0, LENF, NLNKF) - 1
            DO 120 IFAC = LENF(IELB-1)+1, LENF(IELB)
               IF (HIDEF(IFAC) .GE. KFAWAY) THEN
                  DO 110 ILINK = 1, NLNKF(IELB)
                     ISBACK(LINKF(IXL0+ILINK)) = .TRUE.
  110             CONTINUE
               END IF
               IXL0 = IXL0 + NLNKF(IELB)
  120       CONTINUE
         END IF
  130 CONTINUE

      NEDGES = 0
      nmov = 0
      DO 190 IELB = 1, NELBLK
         IF (NLNKE(IELB) .GT. 4 .OR. NAMELB(IELB)(:3) .eq. 'TET') THEN

C         --Eliminate faces of a selected element block
            IF (NOTSEL .AND. (IELBST(IELB) .GT. 0)) GOTO 190

            DO 180 IFAC = LENF(IELB-1)+1, LENF(IELB)
               IF (HIDEF(IFAC) .LT. KFOUT) THEN
                  IXL0 = IDBLNK (IELB, IFAC, LENF, NLNKF) - 1

C               --Eliminate faces that do not have any nodes in faces
C               --that point away

                  NBACK = 0
                  DO 140 ILINK = 1, NLNKF(IELB)
                     IF (ISBACK(LINKF(IXL0+ILINK))) NBACK = NBACK + 1
  140             CONTINUE
                  IF (NBACK .LT. 2) GOTO 180

C               --Extract face lines

                  NOLD = NEDGES
                  N2 = LINKF(IXL0+NLNKF(IELB))
                  LREFN2 = LREF(N2)
                  LSTREF = LREFN2

                  DO 170 ILINK = 1, NLNKF(IELB)
                     N1 = N2
                     N2 = LINKF(IXL0+ILINK)
                     LREFN1 = LREFN2
                     IF (ILINK .LT. NLNKF(IELB)) THEN
                        LREFN2 = LREF(N2)
                     ELSE
                        LREFN2 = LSTREF
                     END IF

                     IF (n1 .eq. n2) goto 170
                     IF (.NOT. ISBACK(N1)) GOTO 170
                     IF (.NOT. ISBACK(N2)) GOTO 170
                     IF ((HIDENP(N1) .GT. KNVIS)
     &                  .AND. (HIDENP(N2) .GT. KNVIS)) GOTO 170
                     IF (HIDENP(N1) .GE. KNHID) GOTO 170
                     IF (HIDENP(N2) .GE. KNHID) GOTO 170
                     NMIN = MIN (N1, N2)
                     NMAX = MAX (N1, N2)

C                  --Search for line in existing lines

                     DO 150 IL = MIN (LREFN1, LREFN2, NOLD), 1, -1
                       IF (IEDSET(1,IL) .EQ. NMIN .AND.
     *                     IEDSET(2,IL) .EQ. NMAX) GOTO 160
  150                CONTINUE
  160                CONTINUE

C                  --Insert new line or pointer to face if duplicate

                     IF (IL .GT. 0) THEN
                        IF (NBACK .LE. 2) IEDSET(0,IL) = IFAC
                        nmov = nmov + 1
                     ELSE
                        NEDGES = NEDGES + 1
                        IEDSET(0,NEDGES) = IFAC
                        IEDSET(1,NEDGES) = NMIN
                        IEDSET(2,NEDGES) = NMAX
                        LREF(N1) = NEDGES
                        LREF(N2) = NEDGES
                     END IF
  170             CONTINUE
               END IF
  180       CONTINUE
         END IF
  190 CONTINUE

      if ((cdebug .eq. 'HIDDEN') .and. (idebug .ge. 1))
     &   write (*, '(1x,a,i5)') 'non-shell visible edge set =', nedges
      if ((cdebug .eq. 'HIDDEN') .and. (idebug .ge. 1))
     &   write (*, '(1x,a,i5)') '***removed =', nmov
  200 CONTINUE

      IF (.NOT. ANYSHE) GOTO 320

C   --Mark nodes in shell faces with any nodes hidden

      DO 210 INP = 1, NUMNPF
         IF (LREF(INP) .LE. 0) THEN
            NREF(INP) = 0
         ELSE
            NREF(INP) = 1
         END IF
  210 CONTINUE

      CALL INILOG (NUMNPF, .FALSE., ISBACK)

      DO 250 IELB = 1, NELBLK
         IF (NLNKE(IELB) .EQ. 4 .AND. NAMELB(IELB)(:3) .ne. 'TET') THEN
            IXL0 = IDBLNK (IELB, 0, LENF, NLNKF) - 1
            DO 240 IFAC = LENF(IELB-1)+1, LENF(IELB)
               NHID = 0
               DO 220 ILINK = 1, NLNKF(IELB)
                  IF (HIDENP(LINKF(IXL0+ILINK)) .GT. KNVIS)
     &               NHID = NHID + 1
  220          CONTINUE
               IF (NHID .GT. 0) THEN
                  DO 230 ILINK = 1, NLNKF(IELB)
C????                     ISBACK(LINKF(IXL0+ILINK)) = .TRUE.
  230             CONTINUE
               END IF
               IXL0 = IXL0 + NLNKF(IELB)
  240       CONTINUE
         END IF
  250 CONTINUE

      NEWEDG = NEDGES + 1
      nmov = 0

      call iniint(numnpf, 0, mref)
      do i=nedges, 1, -1
        mref(iedset(1,i)) = i
        mref(iedset(2,i)) = i
      end do

      DO 310 IELB = 1, NELBLK
         IF (NLNKE(IELB) .EQ. 4 .AND. NAMELB(IELB)(:3) .ne. 'TET') THEN

C         --Eliminate faces of a selected element block
            IF (NOTSEL .AND. (IELBST(IELB) .GT. 0)) GOTO 310

            DO 300 IFAC = LENF(IELB-1)+1, LENF(IELB)
               IF (HIDEF(IFAC) .LT. KFOUT) THEN
                  IXL0 = IDBLNK (IELB, IFAC, LENF, NLNKF) - 1

C               --Extract face lines

                  NOLD = NEDGES
                  N2 = LINKF(IXL0+NLNKF(IELB))
                  LREFN2 = LREF(N2)
                  LSTREF = LREFN2

                  DO 290 ILINK = 1, NLNKF(IELB)
                     N1 = N2
                     N2 = LINKF(IXL0+ILINK)
                     LREFN1 = LREFN2
                     IF (ILINK .LT. NLNKF(IELB)) THEN
                        LREFN2 = LREF(N2)
                     ELSE
                        LREFN2 = LSTREF
                     END IF

                     IF ((HIDENP(N1) .GT. KNVIS)
     &                  .AND. (HIDENP(N2) .GT. KNVIS)) GOTO 290
                     IF (HIDENP(N1) .GE. KNHID) GOTO 290
                     IF (HIDENP(N2) .GE. KNHID) GOTO 290
                     NMIN = MIN (N1, N2)
                     NMAX = MAX (N1, N2)

C                  --Search for line in existing lines

                     IMIN = max(mref(n1), mref(n2),1)
                     DO 260 IL = MIN (LREFN1, LREFN2, NOLD), IMIN, -1
                       IF (IEDSET(1,IL) .EQ. NMIN .AND.
     *                     IEDSET(2,IL) .EQ. NMAX) GOTO 270
 260                 CONTINUE
 270                 CONTINUE

                     IF (IL .GT. 0) THEN
                        IF (IL .LT. NEWEDG) THEN

C                        --Leave edge matching non-shell as edge
                           CONTINUE

                        ELSE IF (ISBACK(N1) .OR. ISBACK(N2)) THEN

C                        --Adjust pointer to face if duplicate line and either
C                        --node is hidden in a shell quad
                           NHID = 0
                           DO 280 I = 1, NLNKF(IELB)
                              IF (HIDENP(LINKF(IXL0+I)) .GT. KNVIS)
     &                           NHID = NHID + 1
  280                      CONTINUE
                           IF (NHID .LE. 0) IEDSET(0,NEDGES) = IFAC
C????C should check the ZQ coordinate

                        ELSE

C                        --Delete duplicate line if both nodes visible
C                        --in all shell quads

                           IEDSET(0,IL) = IEDSET(0,NEDGES)
                           IEDSET(1,IL) = IEDSET(1,NEDGES)
                           IEDSET(2,IL) = IEDSET(2,NEDGES)
                           NREF(N1) = NREF(N1) - 1
                           NREF(N2) = NREF(N2) - 1
                           IF (NREF(N1) .LE. 0) LREF(N1) = 0
                           IF (NREF(N2) .LE. 0) LREF(N2) = 0
                           NEDGES = NEDGES - 1
                           IF (NOLD .GT. NEDGES) NOLD = NEDGES
                           nmov = nmov + 1
                        END IF
                     ELSE

C                     --Insert new line

                        NEDGES = NEDGES + 1
                        IEDSET(0,NEDGES) = IFAC
                        IEDSET(1,NEDGES) = NMIN
                        IEDSET(2,NEDGES) = NMAX
                        NREF(N1) = NREF(N1) + 1
                        NREF(N2) = NREF(N2) + 1
                        LREF(N1) = NEDGES
                        LREF(N2) = NEDGES
                        if (mref(n1) .eq. 0) mref(n1) = nedges
                        if (mref(n2) .eq. 0) mref(n2) = nedges
                     END IF
  290             CONTINUE
               END IF
  300       CONTINUE
         END IF
  310 CONTINUE

      if ((cdebug .eq. 'HIDDEN') .and. (idebug .ge. 1))
     &   write (*, '(1x,a,i5)') 'shell visible edge set =',
     &   nedges - newedg + 1
      if ((cdebug .eq. 'HIDDEN') .and. (idebug .ge. 1))
     &   write (*, '(1x,a,i5)') '***removed =', nmov
  320 CONTINUE

C   --Make sure hidden node is in IEDSET(2,x)

      DO 330 IEDG = 1, NEDGES
         IF (HIDENP(IEDSET(1,IEDG)) .GT. KNVIS) THEN
            I = IEDSET(1,IEDG)
            IEDSET(1,IEDG) = IEDSET(2,IEDG)
            IEDSET(2,IEDG) = I
         END IF
  330 CONTINUE

      RETURN
      END

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


text:
* *******************************************************************
* COPYRIGHT (c) 1972 Hyprotech UK
* All rights reserved.
*
* None of the comments in this Copyright notice between the lines
* of asterisks shall be removed or altered in any way.
*
* This Package is intended for compilation without modification,
* so most of the embedded comments have been removed.
*
* ALL USE IS SUBJECT TO LICENCE. For full details of an HSL ARCHIVE
* Licence, see http://hsl.rl.ac.uk/archive/cou.html
*
* Please note that for an HSL ARCHIVE Licence:
*
* 1. The Package must not be copied for use by any other person.
*    Supply of any part of the library by the Licensee to a third party
*    shall be subject to prior written agreement between AEA
*    Hyprotech UK Limited and the Licensee on suitable terms and
*    conditions, which will include financial conditions.
* 2. All information on the Package is provided to the Licensee on the
*    understanding that the details thereof are confidential.
* 3. All publications issued by the Licensee that include results obtained
*    with the help of one or more of the Packages shall acknowledge the
*    use of the Packages. The Licensee will notify the Numerical Analysis
*    Group at Rutherford Appleton Laboratory of any such publication.
* 4. The Packages may be modified by or on behalf of the Licensee
*    for such use in research applications but at no time shall such
*    Packages or modifications thereof become the property of the
*    Licensee. The Licensee shall make available free of charge to the
*    copyright holder for any purpose all information relating to
*    any modification.
* 5. Neither CCLRC nor Hyprotech UK Limited shall be liable for any
*    direct or consequential loss or damage whatsoever arising out of
*    the use of Packages by the Licensee.
* *******************************************************************
*
*######DATE 8 Dec 1992
C       Toolpack tool decs employed.
C       B21 reference removed in MA20BD.
C       ZERO made PARAMETER.
C       Arg dimensions set to *.
C
      SUBROUTINE MA20AD(Q,D,A,R,S,IQ,M,N,TOLER)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
      DOUBLE PRECISION TOLER
      INTEGER IQ,M,N
      DOUBLE PRECISION A(*),D(*),Q(IQ,*),R(*)
      INTEGER S(*)
      DOUBLE PRECISION B,B21,BIG,MAX,MIN,PIVOT,QOUTIN,SUM
      INTEGER I,IN,J,K,KL,KOUNT,KR,L,M1,M2,N1,N2,OUT
      LOGICAL STAGE,TEST
      DOUBLE PRECISION FD05AD
      EXTERNAL FD05AD
      INTRINSIC DABS
      BIG = FD05AD(5)*.01D0
      M2 = M + 2
      N2 = N + 2
      M1 = M + 1
      N1 = N + 1
      DO 1 J = 1,N
        Q(M2,J) = J
    1 A(J) = 0.
      DO 3 I = 1,M
        Q(I,N2) = N + I
        D(I) = 0.
        IF (Q(I,N1).GE.0) GO TO 3
        DO 2 J = 1,N2
    2   Q(I,J) = -Q(I,J)
    3 CONTINUE
      DO 5 J = 1,N1
        SUM = 0.
        DO 4 I = 1,M
    4   SUM = SUM + Q(I,J)
    5 Q(M1,J) = SUM
      STAGE = .TRUE.
      KOUNT = 0
      KR = 1
      KL = 1
    6 MAX = -1.
      DO 7 J = KR,N
        IF (DABS(Q(M2,J)).GT.N) GO TO 7
        B = DABS(Q(M1,J))
        IF (B.LE.MAX) GO TO 7
        MAX = B
        IN = J
    7 CONTINUE
      IF (Q(M1,IN).GE.0) GO TO 9
      DO 8 I = 1,M2
    8 Q(I,IN) = -Q(I,IN)
    9 K = 0
      DO 10 I = KL,M
        B = Q(I,IN)
        IF (B.LE.TOLER) GO TO 10
        K = K + 1
        R(K) = Q(I,N1)/B
        S(K) = I
        TEST = .TRUE.
   10 CONTINUE
   11 IF (K.GT.0) GO TO 12
      TEST = .FALSE.
      GO TO 14
   12 MIN = BIG
      DO 13 I = 1,K
        IF (R(I).GE.MIN) GO TO 13
        J = I
        MIN = R(I)
        OUT = S(I)
   13 CONTINUE
      R(J) = R(K)
      S(J) = S(K)
      K = K - 1
   14 IF (TEST .OR. .NOT.STAGE) GO TO 16
      DO 15 I = 1,M2
        B = Q(I,KR)
        Q(I,KR) = Q(I,IN)
   15 Q(I,IN) = B
      KR = KR + 1
      GO TO 25
   16 IF (TEST) GO TO 17
      Q(M2,N1) = 2.
      GO TO 34
   17 PIVOT = Q(OUT,IN)
      IF (Q(M1,IN)-PIVOT-PIVOT.LE.TOLER) GO TO 19
      DO 18 J = KR,N1
        B = Q(OUT,J)
        Q(M1,J) = Q(M1,J) - B - B
   18 Q(OUT,J) = -B
      Q(OUT,N2) = -Q(OUT,N2)
      GO TO 11
   19 DO 20 J = KR,N1
        IF (J.EQ.IN) GO TO 20
        Q(OUT,J) = Q(OUT,J)/PIVOT
   20 CONTINUE
      QOUTIN = Q(OUT,IN)
      Q(OUT,IN) = ZERO
      DO 21 J = KR,N1
        IF (J.EQ.IN) GO TO 21
        B21 = -Q(OUT,J)
        DO 22 I = 1,M1
          Q(I,J) = Q(I,J) + B21*Q(I,IN)
   22   CONTINUE
   21 CONTINUE
      Q(OUT,IN) = QOUTIN
      DO 23 I = 1,M1
        IF (I.EQ.OUT) GO TO 23
        Q(I,IN) = -Q(I,IN)/PIVOT
   23 CONTINUE
      Q(OUT,IN) = 1./PIVOT
      B = Q(OUT,N2)
      Q(OUT,N2) = Q(M2,IN)
      Q(M2,IN) = B
      KOUNT = KOUNT + 1
      IF (.NOT.STAGE) GO TO 26
      KL = KL + 1
      DO 24 J = KR,N2
        B = Q(OUT,J)
        Q(OUT,J) = Q(KOUNT,J)
   24 Q(KOUNT,J) = B
   25 IF (KOUNT+KR.NE.N1) GO TO 6
      STAGE = .FALSE.
   26 MAX = -BIG
      DO 28 J = KR,N
        B = Q(M1,J)
        IF (B.GE.0) GO TO 27
        IF (B.GT.-2.) GO TO 28
        B = -B - 2.
   27   IF (B.LE.MAX) GO TO 28
        MAX = B
        IN = J
   28 CONTINUE
      IF (MAX.LE.TOLER) GO TO 30
      IF (Q(M1,IN).GT.0) GO TO 9
      DO 29 I = 1,M2
   29 Q(I,IN) = -Q(I,IN)
      Q(M1,IN) = Q(M1,IN) - 2.
      GO TO 9
   30 L = KL - 1
      DO 32 I = 1,L
        IF (Q(I,N1).GE.0) GO TO 32
        DO 31 J = KR,N2
   31   Q(I,J) = -Q(I,J)
   32 CONTINUE
      Q(M2,N1) = 0.
      IF (KR.NE.1) GO TO 34
      DO 33 J = 1,N
        B = DABS(Q(M1,J))
        IF (B.LE.TOLER .OR. 2D0-B.LE.TOLER) GO TO 34
   33 CONTINUE
      Q(M2,N1) = 1.
   34 DO 37 I = 1,M
        K = Q(I,N2)
        B = Q(I,N1)
        IF (K.GT.0) GO TO 35
        K = -K
        B = -B
   35   IF (I.GE.KL) GO TO 36
        A(K) = B
        GO TO 37
   36   K = K - N
        D(K) = B
   37 CONTINUE
      Q(M2,N2) = KOUNT
      Q(M1,N2) = N1 - KR
      SUM = 0.
      DO 38 I = KL,M
   38 SUM = SUM + Q(I,N1)
      Q(M1,N1) = SUM
      RETURN
      END
      SUBROUTINE MA20BD(Q,D,A,R,S,IQ,M,N,TOLER)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
      DOUBLE PRECISION TOLER
      INTEGER IQ,M,N
      DOUBLE PRECISION A(*),D(*),Q(IQ,*),R(*)
      INTEGER S(M)
      DOUBLE PRECISION A1,A2,B,BIG,MAX,MIN,PIVOT,QOUTIN,SUM
      INTEGER I,IFORCE,IN,IN2,J,K,KOUNT,M1,M2,N1,N2,OUT
      LOGICAL TEST
      DOUBLE PRECISION FD05AD
      EXTERNAL FD05AD
      INTRINSIC DABS,DMAX1,IABS,INT
      BIG = FD05AD(5)*.01D0
      M2 = M + 2
      N2 = N + 2
      M1 = M + 1
      N1 = N + 1
      IFORCE = INT(1.5*N)
      DO 1 J = 1,N
        Q(M2,J) = J
    1 A(J) = 0.
      DO 3 I = 1,M
        Q(I,N2) = N + I
        D(I) = 0.
        IF (Q(I,N1).GE.0) GO TO 3
        DO 2 J = 1,N2
    2   Q(I,J) = -Q(I,J)
    3 CONTINUE
      DO 5 J = 1,N1
        SUM = 0.
        DO 4 I = 1,M
    4   SUM = SUM + Q(I,J)
    5 Q(M1,J) = SUM
      KOUNT = 0
    6 A1 = -BIG
      A2 = -BIG
      DO 9 J = 1,N
        B = Q(M1,J)
        IF (DABS(Q(M2,J)).LE.N) GO TO 8
        IF (B.GE.0.) GO TO 7
        B = -B - 2.
    7   IF (B.LE.A2) GO TO 9
        A2 = B
        IN2 = J
        GO TO 9
    8   IF (B.LE.A1) GO TO 9
        A1 = B
        IN = J
    9 CONTINUE
      IF (KOUNT.LE.IFORCE .AND. A1.GT.TOLER) GO TO 11
      MAX = DMAX1(A1,A2)
      IF (MAX.LE.TOLER) GO TO 24
      IF (MAX.EQ.A1) GO TO 11
      IN = IN2
      IF (Q(M1,IN).GE.0.) GO TO 11
      DO 10 I = 1,M2
   10 Q(I,IN) = -Q(I,IN)
      Q(M1,IN) = Q(M1,IN) - 2.
   11 K = 0
      DO 12 I = 1,M
        B = Q(I,IN)
        IF (B.LE.TOLER) GO TO 12
        K = K + 1
        R(K) = Q(I,N1)/B
        S(K) = I
        TEST = .TRUE.
   12 CONTINUE
   13 IF (K.GT.0) GO TO 14
      TEST = .FALSE.
      GO TO 16
   14 MIN = BIG
      DO 15 I = 1,K
        IF (R(I).GE.MIN) GO TO 15
        J = I
        MIN = R(I)
        OUT = S(I)
   15 CONTINUE
      PIVOT = Q(OUT,IN)
      IF (DABS(Q(OUT,N2)).LE.N) GO TO 19
      R(J) = R(K)
      S(J) = S(K)
      K = K - 1
   16 IF (TEST) GO TO 17
      Q(M2,N1) = 2.
      GO TO 25
   17 IF (Q(M1,IN)-PIVOT-PIVOT.LE.TOLER) GO TO 19
      DO 18 J = 1,N1
        B = Q(OUT,J)
        Q(M1,J) = Q(M1,J) - B - B
   18 Q(OUT,J) = -B
      Q(OUT,N2) = -Q(OUT,N2)
      GO TO 13
   19 DO 20 J = 1,N1
        IF (J.EQ.IN) GO TO 20
        Q(OUT,J) = Q(OUT,J)/PIVOT
   20 CONTINUE
      QOUTIN = Q(OUT,IN)
      Q(OUT,IN) = ZERO
      DO 21 J = 1,N1
        IF (J.EQ.IN) GO TO 21
        B = -Q(OUT,J)
        DO 22 I = 1,M1
          Q(I,J) = Q(I,J) + B*Q(I,IN)
   22   CONTINUE
   21 CONTINUE
      Q(OUT,IN) = QOUTIN
      DO 23 I = 1,M1
        IF (I.EQ.OUT) GO TO 23
        Q(I,IN) = -Q(I,IN)/PIVOT
   23 CONTINUE
      Q(OUT,IN) = 1./PIVOT
      B = Q(OUT,N2)
      Q(OUT,N2) = Q(M2,IN)
      Q(M2,IN) = B
      KOUNT = KOUNT + 1
      GO TO 6
   24 Q(M2,N1) = 1.
   25 DO 28 I = 1,M
        K = Q(I,N2)
        B = Q(I,N1)
        IF (IABS(K).GT.N) GO TO 26
        A(K) = B
        GO TO 28
   26   IF (K.GT.0) GO TO 27
        K = -K
        B = -B
   27   K = K - N
        D(K) = B
   28 CONTINUE
      Q(M2,N2) = KOUNT
      SUM = 0.
      DO 29 I = 1,M
   29 SUM = SUM + DABS(D(I))
      Q(M1,N1) = SUM
      RETURN
      END

max_forks_repo_name: dynamics-of-stellar-systems/dynamite


text:
MODULE cgpc_hprsdft_module

!$ use omp_lib
  use rgrid_module, only: Igrid,Hgrid
  use rgrid_mol_module, only: Hsize, LL
  use bc_module
  use bcset_0_module, only: bcset_0
  use kinetic_variables, only: ggg
  use parallel_module
  use watch_module, only: watchb_omp, time_cgpc, time_bcfd

  implicit none

  PRIVATE
  PUBLIC :: precond_hprsdft, init_cgpc_hprsdft

#ifdef _DRSDFT_
  real(8),allocatable :: ftmp2(:,:),gtmp2(:,:)
  real(8),allocatable :: rk_pc(:,:), pk_pc(:,:)
  real(8),parameter :: zero=0.0d0
#else
  complex(8),allocatable :: ftmp2(:,:),gtmp2(:,:)
  complex(8),allocatable :: rk_pc(:,:), pk_pc(:,:)
  complex(8),parameter :: zero=(0.0d0,0.0d0)
#endif

  logical :: ompflag1
  integer :: omp1,omp2,ompi,ompnprocs,ompnsw,ompmyrank
  integer :: ompn1,ompn2,ompA3,ompB3
  real(8),allocatable :: ompr1s(:,:)

  integer :: a1b,b1b,a2b,b2b ,mloop,SYStype, ML_0
  real(8) :: H1,H2,H3
  logical :: init_flag=.false.

!$omp threadprivate( omp1,omp2,ompi,ompnsw,ompmyrank,ompnprocs &
!$omp               ,ompn1,ompn2,ompA3,ompB3 )

CONTAINS

  SUBROUTINE init_cgpc_hprsdft( mloop_in, systype_in )
    implicit none
    integer,intent(IN) :: mloop_in, systype_in
    integer :: mm,m1,m2,m3,i,j
    integer :: ompblock,ompblock0

    if ( init_flag ) return
    init_flag = .true.

    mloop = mloop_in
    SYStype = systype_in

    H1=Hgrid(1)
    H2=Hgrid(2)
    H3=Hgrid(3)

    mm = Igrid(2,0) - Igrid(1,0) + 1
    m1 = Igrid(2,1) - Igrid(1,1) + 1
    m2 = Igrid(2,2) - Igrid(1,2) + 1
    m3 = Igrid(2,3) - Igrid(1,3) + 1

    a1b = Igrid(1,1)
    b1b = Igrid(2,1)
    a2b = Igrid(1,2)
    b2b = Igrid(2,2)

    ML_0 = Igrid(1,0)

!$OMP parallel private( ompblock,ompblock0,i,j )

    ompnprocs = 1
!$  ompnprocs = omp_get_num_threads()
    ompmyrank = 0
!$  ompmyrank = omp_get_thread_num()

    ompblock0=0
    ompblock=0
    do i=1,mm
       j=mod(i-1,ompnprocs)
       if ( j == ompmyrank ) then
          ompblock = ompblock + 1
       else if ( j < ompmyrank ) then
          ompblock0 = ompblock0 + 1
       end if
    end do

    omp1 = ompblock0 + 1
    omp2 = omp1 + ompblock - 1

!    ompn1 = Igrid(1,0) + ompblock0
!    ompn2 = ompn1 + ompblock - 1
    ompn1 = omp1
    ompn2 = omp2

!$OMP single
    allocate( ompr1s(MB_d,0:ompnprocs-1) ) ; ompr1s=0.0d0
!$OMP end single

    ompblock0=0
    ompblock=0
    do i=1,m3
       j=mod(i-1,ompnprocs)
       if ( j == ompmyrank ) then
          ompblock = ompblock + 1
       else if ( j < ompmyrank ) then
          ompblock0 = ompblock0 + 1
       end if
    end do

    ompA3 = Igrid(1,3) + ompblock0
    ompB3 = ompA3 + ompblock - 1

    ompnsw = ( ompA3-Igrid(1,3) )*m1*m2

!$OMP end parallel

    allocate( rk_pc(mm,MB_d) ) ; rk_pc=zero
    allocate( pk_pc(mm,MB_d) ) ; pk_pc=zero
    allocate( gtmp2(mm,MB_d) ) ; gtmp2=zero
    allocate( ftmp2(mm,MB_d) ) ; ftmp2=zero

  END SUBROUTINE init_cgpc_hprsdft

  SUBROUTINE precond_hprsdft( E, k, s, nn, ML0, gk, Pgk )
    implicit none
    integer,intent(IN)       :: k,s,nn,ML0
    real(8),intent(IN)       :: E(nn)
#ifdef _DRSDFT_
    real(8),intent(INOUT) :: gk(ML0,nn), Pgk(ML0,nn)
#else
    complex(8),intent(INOUT) :: gk(ML0,nn), Pgk(ML0,nn)
#endif
    real(8),parameter :: ep=1.d-24
    real(8) :: rr0(nn),rr1(nn),pAp(nn),a(nn),E0(nn),b
    real(8) :: ttmp(2)
    integer :: n,ierr,iloop,mm

    if ( mloop <= 0 ) return

    E0(:) = 0.0d0
    ompflag1 = .FALSE.
    time_bcfd(:,:) = 0.0d0

!$omp parallel private ( n, iloop, b )

    !call watchb_omp( ttmp )

    gtmp2(omp1:omp2,1:nn) = gk(ompn1:ompn2,1:nn)

    !call watchb_omp( ttmp, time_cgpc(1,1) )

    call precond_cg_mat( E0, k, s, ML0, nn )

    !call watchb_omp( ttmp, time_cgpc(1,2) )

    do n=1,nn
       rk_pc(omp1:omp2,n) = gk(ompn1:ompn2,n) - ftmp2(omp1:omp2,n)
       pk_pc(omp1:omp2,n) = rk_pc(omp1:omp2,n)
    end do

    !call watchb_omp( ttmp, time_cgpc(1,1) )

    do n=1,nn
       ompr1s(n,ompmyrank) = sum( abs(rk_pc(omp1:omp2,n))**2 )
    end do
!$omp barrier
!$omp master
    do ompi=1,ompnprocs-1
       ompr1s(1:nn,0) = ompr1s(1:nn,0) + ompr1s(1:nn,ompi)
    end do
    call mpi_allreduce(ompr1s,rr1,nn,mpi_real8,mpi_sum,comm_grid,ierr)
    if ( all( rr1(1:nn)<ep ) ) ompflag1 = .TRUE.
!$omp end master
!$omp barrier

    !call watchb_omp( ttmp, time_cgpc(1,3) )

    if ( ompflag1 ) goto 99

    do iloop=1,mloop

       !call watchb_omp( ttmp )

       gtmp2(omp1:omp2,1:nn) = pk_pc(omp1:omp2,1:nn)

       !call watchb_omp( ttmp, time_cgpc(1,1) )

       call precond_cg_mat( E0, k, s, ML0, nn )

       !call watchb_omp( ttmp, time_cgpc(1,2) )

       do n=1,nn
#ifdef _DRSDFT_
          ompr1s(n,ompmyrank) &
               =sum( pk_pc(omp1:omp2,n)*ftmp2(omp1:omp2,n) )
#else
          ompr1s(n,ompmyrank) &
               =sum( conjg(pk_pc(omp1:omp2,n))*ftmp2(omp1:omp2,n) )
#endif
       end do
!$omp barrier
!$omp master
       do ompi=1,ompnprocs-1
          ompr1s(1:nn,0) = ompr1s(1:nn,0) + ompr1s(1:nn,ompi)
       end do
       call mpi_allreduce(ompr1s,pAp,nn,mpi_real8,mpi_sum,comm_grid,ierr)
       do n=1,nn
          rr0(n)=rr1(n)
          a(n)=rr0(n)/pAp(n)
       end do
!$omp end master
!$omp barrier

       !call watchb_omp( ttmp, time_cgpc(1,3) )

       do n=1,nn
          Pgk(ompn1:ompn2,n) = Pgk(ompn1:ompn2,n) + a(n)*pk_pc(omp1:omp2,n)
       end do

       !call watchb_omp( ttmp, time_cgpc(1,1) )

       if ( iloop == mloop ) exit

       do n=1,nn
          rk_pc(omp1:omp2,n)=rk_pc(omp1:omp2,n)-a(n)*ftmp2(omp1:omp2,n)
       end do

       !call watchb_omp( ttmp, time_cgpc(1,1) )

       do n=1,nn
          ompr1s(n,ompmyrank)=sum( abs(rk_pc(omp1:omp2,n))**2 )
       end do
!$omp barrier
!$omp master
       do ompi=1,ompnprocs-1
          ompr1s(1:nn,0)=ompr1s(1:nn,0)+ompr1s(1:nn,ompi)
       end do
       call mpi_allreduce(ompr1s,rr1,nn,mpi_real8,mpi_sum,comm_grid,ierr)
!$omp end master
!$omp barrier

       !call watchb_omp( ttmp, time_cgpc(1,3) )

       do n=1,nn
          b=rr1(n)/rr0(n)
          pk_pc(omp1:omp2,n) = rk_pc(omp1:omp2,n) + b*pk_pc(omp1:omp2,n)
       end do

       !call watchb_omp( ttmp, time_cgpc(1,1) )

    end do ! iloop

99  continue

!$omp end parallel

    time_cgpc(1:2,8:13) = time_cgpc(1:2,8:13) + time_bcfd(1:2,1:6)

    return

  END SUBROUTINE precond_hprsdft

  SUBROUTINE precond_cg_mat( E, k, s, mm, nn )
    implicit none
    integer,intent(IN) :: k,s,mm,nn
    real(8),intent(INOUT) :: E(nn)
    select case(SYStype)
    case(0)
       call precond_cg_mat2_omp(E,k,s,mm,nn)
    case(1)
       call precond_cg_mat_mol(E,k,s,mm,nn)
!    case(3)
!       call precond_cg_mat_esm(E,k,s,mm,nn)
    end select
  END SUBROUTINE precond_cg_mat

  SUBROUTINE precond_cg_mat2_omp(E,k,s,mm,nn)

    implicit none

    integer,intent(IN) :: k,s,mm,nn
    real(8) :: E(nn)
    real(8) :: c,c1,c2,c3,d,ttmp(2)
    integer :: n,i,i1,i2,i3

    !call watchb_omp( ttmp )

    c =ggg(1)/H1**2+ggg(2)/H2**2+ggg(3)/H3**2
    c1=-0.5d0/H1**2*ggg(1)
    c2=-0.5d0/H2**2*ggg(2)
    c3=-0.5d0/H3**2*ggg(3)

    do n=1,nn
       d=c-E(n)
       do i=omp1,omp2
          ftmp2(i,n)=d*gtmp2(i,n)
       end do
    end do

!$omp barrier
    !call watchb_omp( ttmp, time_cgpc(1,4) )

    do n=1,nn
       i=ompnsw
       do i3=ompA3,ompB3
       do i2=a2b,b2b
       do i1=a1b,b1b
          i=i+1
          www(i1,i2,i3,n)=gtmp2(i,n)
       end do
       end do
       end do
    end do

!$OMP barrier
    !call watchb_omp( ttmp, time_cgpc(1,5) )

    !call bcset_0(1,nn,1,0)
    call bcset_1(1,nn,1,0)

!$OMP barrier
    !call watchb_omp( ttmp, time_cgpc(1,6) )

    do n=1,nn
       i=ompnsw
       do i3=ompA3,ompB3
       do i2=a2b,b2b
       do i1=a1b,b1b
          i=i+1
          ftmp2(i,n)=ftmp2(i,n) &
               +c1*( www(i1+1,i2,i3,n)+www(i1-1,i2,i3,n) ) &
               +c2*( www(i1,i2+1,i3,n)+www(i1,i2-1,i3,n) ) &
               +c3*( www(i1,i2,i3+1,n)+www(i1,i2,i3-1,n) )
       end do
       end do
       end do
    end do

!$omp barrier
    !call watchb_omp( ttmp, time_cgpc(1,7) )

    return

  END SUBROUTINE precond_cg_mat2_omp

  SUBROUTINE precond_cg_mat_mol(E,k,s,mm,nn)
    implicit none
    integer,intent(IN) :: k,s,mm,nn
    real(8),intent(INOUT) :: E(nn)
    real(8) :: c,c1,c2,c3,d
    integer :: n,i,i1,i2,i3,j

    c  =  3.d0/Hsize**2
    c1 = -0.5d0/Hsize**2
    c2 = -0.5d0/Hsize**2
    c3 = -0.5d0/Hsize**2

    do n=1,nn
       d=c-E(n)
       do i=omp1,omp2
          ftmp2(i,n)=d*gtmp2(i,n)
       end do
    end do

!!$OMP workshare
!    www(:,:,:,:)=zero
!!$OMP end workshare
    do n=1,nn
       do i=omp1,omp2
          j=i+ML_0-1
          www( LL(1,j),LL(2,j),LL(3,j),n ) = gtmp2(i,n)
       end do
    end do
!$OMP barrier

    call bcset_1(1,nn,1,0)
!$OMP barrier

    do n=1,nn
       do i=omp1,omp2
          j=i+ML_0-1
          i1=LL(1,j)
          i2=LL(2,j)
          i3=LL(3,j)
          ftmp2(i,n)=ftmp2(i,n)+c1*( www(i1-1,i2,i3,n)+www(i1+1,i2,i3,n) ) &
                               +c2*( www(i1,i2-1,i3,n)+www(i1,i2+1,i3,n) ) &
                               +c3*( www(i1,i2,i3-1,n)+www(i1,i2,i3+1,n) )
       end do
    end do
!$OMP barrier

    return
  END SUBROUTINE precond_cg_mat_mol

END MODULE cgpc_hprsdft_module

max_stars_repo_name: j-iwata/RSDFT

max_issues_repo_name: j-iwata/RSDFT

max_forks_repo_name: j-iwata/RSDFT


text:
! { dg-do run }
! { dg-options "-std=gnu" }
program testbyte
  integer(1) :: ii = 7
  call foo(ii)
end program testbyte

subroutine foo(ii)
  integer(1) ii
  byte b
  b = ii
  call bar(ii,b)
end subroutine foo

subroutine bar(ii,b)
  integer (1) ii
  byte b
  if (b.ne.ii) then
!     print *,"Failed"
     call abort
  end if
end subroutine bar

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
 Temescal Apartments offers 1 bedroom apartments $920 Sept 2013, two bedroom apartments $1350Sept 2013,  3 bedroom townhouses $1700 Sept 2013, 4 bedroom townhouses $2200 Sept 2013.  Pet deposits are $300 per pet.  This complex is on the Unitrans G bus line and J bus line, near The Marketplace.

Temescal apartments is conveniently located in North Davis, within walking distance of the Market Place Shopping Center, to accommodate your shopping and dining needs.  Our property has both 1 & 2 bedroom apartments, as well as 3 & 4 bedroom town homes.   Amidst our beautiful park like landscaping, the front of the property provides bus stops for 2 major campus bus lines (G & J) as well as access to the heart of downtown.  For other travel needs Highway 113 is easily accessible from our property.  Free parking is available on site for all residents.
Temescal provides a large range of Community Amenities.  A sparkling pool and Jacuzzi are a great place to relax during the warm summer days.   We have both an outdoor fitness area as well as an indoor fitness room (complete with both cardio equipment and weights).  Our large dry sauna is a perfect way to end your workout, or to unwind after a long day.  Throughout the property, BBQ picnic areas are available for your use and enjoyment.   Also on site, are two 24 hour laundry rooms with key entry access.  The study lounge is open 24 hours and allows you to access the free wireless internet available throughout the property.  Have some free time on your hands… utilize our game area equipped with a pool table and dart board or come spend some time in our large community area.
Our units offer a variety of fabulous amenities and features.  Whether you live alone, with roommates, or a four legged friend (we are both dog and cat friendly) your unit has everything you need.   Each unit includes free expanded basic cable television, gas stoves, frost free refrigerators, dishwasher, garbage disposal, dual pane windows and ample cabinets and closets for all your storage needs.  Wall to wall carpets in the living room and bedrooms give the unit that extra homey feel.  All units have standard heat and air for climate control. Additionally,  all 2, 3 and 4 bedroom units include a free standing wood burning stove, perfect for warming up the unit during the cold winter nights.   Our whole house fans, included in all units, are a great energy efficient way to cool the house in the summer evenings.  24 hour emergency maintenance is provided for all of your maintenance needs.
We pay water, sewer, and garbage!  Each month you are responsible for your rent and PG&E (to cover utilities used within the unit).  No hidden fees!  Check us out at www.temescalapartments.com and set up an appointment to view your next home today!

  For more information on Davis rental housing, please visit our Housing Guide as well as our Apartments pages.

20070222 18:12:25 nbsp The 2bedroom apartments seem to be very high in demand. I went with my roommate to check out the 1 and 3bedroom units. The layouts are not as thoughtful as we had hoped and the woodburning stove near the foyer continues to boggle me. I suppose if you enjoy burning wood during the 3 weeks that Davis is actually cold enough to warrant it, the stove is a nice amenity in the larger units. AbbYu

20070412 16:32:04 nbsp Stupid 1000character limit!  Temescal is great.  Ive lived in a 3BR/1.5Ba for 3 years and am now in a 2/1.  Prices are reasonable, locations are good.  Great management and maintenance.  The wireless is very slow, but works when SBC goes down.  Great floorplan in the 2BR, decent in the 3BR.  Tons of cabinet space in both.  Big closets.  All in all, great place. Users/TomGarberson

20070921 23:40:05 nbsp Just moved in and internet sucks, anyone know what internet to get that has the best deal? Users/ChrisChen

20070922 00:02:45 nbsp Chris, you might want to take a look at the Broadband page. Users/Graham.Freeman

20070922 02:15:19 nbsp Yeah the internet at Temescal is not reliable. Definitely want to get your own ISP, especially if you like to procrastinate on research papers and whatnot. Users/KaiWan

20090331 11:46:04 nbsp The initial system that was installed did have problems and management has changed the system to accomodate to number of residents using the internet.  Temescal has installed 2 DSL lines with 8 meraki repeaters.  There have been no complaints from our residents since upgrading last year.  The management encourages residents to notify them if they do experience problems.   Users/Management

20100706 02:14:07 nbsp I hate the parking lot here at Temescal. Theres ALWAYS (except during summer when its empty) at least 3 cars who do not have a parking permit to be found parked in the lot. Its so frustrating when I, being at tenant, cannot park in my own parking lot because other people visiting are taking up spaces. Its not like I could park on the street, theres never any spaces! They definitely do not enforce the parking permit requirement, so why should I even have given the office the information on my car and stuck some sticker on my windshield if theres absolutely no risk of being towed? Users/KaprilWooley

20100819 21:30:14 nbsp The wood burning stove is tacky and oddly placed, as are some random alcoves of the 3br that I live in. Management has been reliable and helpful the few times there were problems. The apartments are older and yeah, if you want to watch movies or tv online get your own internet. Its a nice place to live though the apartments are kinda old. Users/argyle

20110304 17:06:03 nbsp Over the December break temescal upgraded the internet again they now have a 20 meg system. I have lived here for several years and I still like it. Users/kenbrown
      FYI, Ken Brown is the assistant manager at Temescal  Users/argyle

20110524 16:16:29 nbsp Awesome place, the managers are very nice people! Just a heads for you people who tend to get packages a lot, they will not sign for packages. Not their fault, more of the parent management company. >.< Users/TheO

20110714 17:03:03 nbsp Temescal Apartments is really old and run down. The managers here are incompetent and really rude towards students. Users/LukeShiver

20140515 12:47:46 nbsp This is my third year living in a four bedroom apartment here. I love it. The managers are nice, the location is great. In general a nice pace for a student to live, much better than half of the other apartment complexes in Davis. Users/sosoli

20140617 00:10:39 nbsp Lived in a 4 Bedroom Townhouse: the managers were pretty friendly and easygoing; maintenance was prompt; parking is ample (with gravel overflow, should be asphalt!); buildings are on the older side; the whole house fan was actually really useful; Temescal wifi sucked; Comcast was great because since the complex includes cable TV, our Blast Plus connection was heavily discounted; right in front of the G and J line; right next to the Marketplace; laundry is $1 Dry/Wash; kitchen stove was gas fueled; afterhours clubhouse access is annoying to deal with (you have to check in every week).
7.5/10 would recommend. Users/compmix

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
program test_dot_product

  write (*, '(i0)') dot_product ((/1, 3, -5/), (/4, -2, -1/))

end program test_dot_product

max_stars_repo_name: djgoku/RosettaCodeData

max_issues_repo_name: djgoku/RosettaCodeData

max_forks_repo_name: djgoku/RosettaCodeData


module ModflowGridModule
  use UTL8MODULE

  implicit none

! Set default access status to private
  private

! Public derived data type definitions
!--------------------------------------
! type:
!--------------------------------------
  type,public :: ModflowGridType
    integer :: GridType = 0
    integer :: CellCount = 0
    integer :: LayerCount = 0
    integer :: JaCount = 0
    integer,dimension(:),allocatable :: JaOffsets, Ja
    double precision,dimension(:),allocatable :: Top
    double precision,dimension(:),allocatable :: SaturatedTop
    double precision,dimension(:),allocatable :: Bottom
    double precision,dimension(:),allocatable :: CellX, CellY
    integer,dimension(:),allocatable :: CellType
    integer,dimension(:),allocatable :: LayerOffsets
    double precision :: OriginX, OriginY, RotationAngle
 contains
    procedure :: GetLayerCellCount
    procedure :: GetLayer
    procedure :: GetLayerCellNumber
    procedure :: GetJaCellConnections
    procedure :: GetJaCellConnectionsCount
    procedure :: GetDZ
    procedure :: GetIDomain
  end type

    contains
!x------------------------------------------
  function GetLayerCellCount(this, layer) result(fval)
  class(ModflowGridType) :: this
  integer,intent(in) :: layer
  double precision :: fval

  fval = this%LayerOffsets(layer + 1) - this%LayerOffsets(layer)

  end function GetLayerCellCount
!------------------------------------------
  function GetLayer(this, cellNumber) result(layer)
    implicit none
    class(ModflowGridType) :: this
    integer, intent(in) :: cellNumber
    integer :: layer, count, n, n1, n2

    do n = 1, this%LayerCount
        n1 = this%LayerOffsets(n)
        n2 = this%LayerOffsets(n + 1)
        if( (cellNumber .gt. n1) .and. (cellNumber .le. n2) ) then
            layer = n
            exit
        end if
    end do

  end function GetLayer
!x------------------------------------------
  function GetLayerCellNumber(this, cellNumber) result(fval)
  class(ModflowGridType) :: this
  integer, intent(in) :: cellNumber
  integer :: layer
  double precision :: fval

  layer = this%GetLayer(cellNumber)
  fval = cellNumber - this%LayerOffsets(layer)

  end function GetLayerCellNumber

  subroutine GetJaCellConnections(this, cellNumber, buffer, bufferSize, cellConnectionCount)
  class(ModflowGridType) :: this
  integer,intent(in) :: cellNumber,bufferSize
  integer,intent(inout) :: cellConnectionCount
  integer,intent(inout),dimension(bufferSize) :: buffer
  integer :: n, offset

  do n = 1, bufferSize
      buffer(n) = -1
  end do

  offset = this%JaOffsets(cellNumber)
  cellConnectionCount = this%JaOffsets(cellNumber + 1) - offset

  do n = 1, cellConnectionCount
      buffer(n) = this%Ja(offset + n)
  end do

  end subroutine GetJaCellConnections

  function GetJaCellConnectionsCount(this, cellNumber) result(count)
  class(ModflowGridType) :: this
  integer,intent(in) :: cellNumber
  integer :: count

  count = this%JaOffsets(cellNumber + 1) - this%JaOffsets(cellNumber)

  end function GetJaCellConnectionsCount

  !x------------------------------------------
  function GetDZ(this, cellNumber) result(fval)
  class(ModflowGridType) :: this
  integer,intent(in) :: cellNumber
  double precision :: fval

  ! Add override code to implement
  fval = this%Top(cellNumber) - this%Bottom(cellNumber)

  end function GetDZ

  !x------------------------------------------
  function GetIDomain(this, cellNumber) result(fval)
    class(ModflowGridType) :: this
    integer,intent(in) :: cellNumber
    integer :: fval

    ! Override this function if necessary
    fval = 1

  end function GetIDomain

end module ModflowGridModule


text:
      PROGRAM DSEX01D
C
      PARAMETER (NUM=1000, NX=21, NY=21, NZ=21)
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
      DOUBLE PRECISION XI(NUM), YI(NUM), ZI(NUM), U(NUM)
      DOUBLE PRECISION XO(NX),  YO(NY),  ZO(NZ),  OUTPUT(NX,NY,NZ)
      DOUBLE PRECISION XMIN,    YMIN,    ZMIN
      DOUBLE PRECISION XMAX,    YMAX,    ZMAX
      REAL             XP(NX),  YP(NY),  ZP(NZ),  OUTP(NX,NY,NZ)
      INTEGER I, J, K, IER
C
      DATA XMIN,YMIN,ZMIN/ -2.D0, -2.D0, -2.D0/
      DATA XMAX,YMAX,ZMAX/  2.D0,  2.D0,  2.D0/
C
C  Create random data in three space and define a function.
C  To get this to work on your system, you may have to insert
C  the correct random number generator for your compiler.
C
      DO 10 I=1,NUM
        XI(I) = XMIN+(XMAX-XMIN)*DBLE(DSRND1D())
        YI(I) = YMIN+(YMAX-YMIN)*DBLE(DSRND1D())
        ZI(I) = ZMIN+(ZMAX-ZMIN)*DBLE(DSRND1D())
         U(I) = XI(I)**2 + YI(I)**2 + ZI(I)**2
   10 CONTINUE
C
C  Create the output grid.
C
      DO 102 I=1,NX
        XO(I) = XMIN+(DBLE(I-1)/DBLE(NX-1))*(XMAX-XMIN)
  102 CONTINUE
C
      DO 103 J =1,NY
        YO(J)= YMIN+(DBLE(J-1)/DBLE(NY-1))*(YMAX-YMIN)
  103 CONTINUE
C
      DO 104 K=1,NZ
        ZO(K) = ZMIN+(DBLE(K-1)/DBLE(NZ-1))*(ZMAX-ZMIN)
  104 CONTINUE
C
C  Interpolate.
C
      CALL DSGRID3D(NUM,XI,YI,ZI,U,NX,NY,NZ,XO,YO,ZO,OUTPUT,IER)
      IF (IER .NE. 0) THEN
        WRITE(6,520) IER
  520   FORMAT(' Error ',I3,' returned from DSGRID3D')
        STOP
      ENDIF
C
C  Pass single precision arrays for plotting an isosurface.
C
      DO 105 I=1,NX
        XP(I) = XO(I)
        DO 106 J=1,NY
          YP(J) = YO(J)
          DO 107 K=1,NZ
            ZP(K) = ZO(K)
            OUTP(I,J,K) = OUTPUT(I,J,K)
  107     CONTINUE
  106   CONTINUE
  105 CONTINUE
C
C  Draw plot.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
      CALL TDEZ3D(NX, NY, NZ, XP, YP, ZP, OUTP, 3.0, 0., 0., 0., 6)
      CALL FRAME
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
      END
      REAL FUNCTION DSRND1D()
C
C  Portable random number generator.
C
      PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773,
     +           MOMDMP=2836)
C
      INTEGER HVLUE, LVLUE, TESTV, NEXTN
      SAVE    NEXTN
      DATA JSEED,IFRST/123456789,0/
C
      IF (IFRST .EQ. 0) THEN
        NEXTN = JSEED
        IFRST = 1
      ENDIF
C
      HVLUE = NEXTN / MOBYMP
      LVLUE = MOD(NEXTN, MOBYMP)
      TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
      IF (TESTV .GT. 0) THEN
        NEXTN = TESTV
      ELSE
        NEXTN = TESTV + MODLUS
      ENDIF
      DSRND1D = REAL(NEXTN)/REAL(MODLUS)
C
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl