module random_mod

contains

  subroutine sgrnd(seed)

    implicit integer(a-z)

    !Period parameters

    parameter(N     =  624)

    dimension mt(0:N-1)

    !The array for the state vector

    common /block/mti,mt
    save   /block/

    !setting initial seeds to mt[N] using
    !the generator Line 25 of Table 1 in
    ![KNUTH 1981, The Art of Computer Programming
    !Vol. 2 (2nd Ed.), pp102]

    mt(0)= iand(seed,-1)
    do mti=1,N-1
       mt(mti) = iand(69069 * mt(mti-1),-1)
    end do

    return
  end subroutine sgrnd

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

  double precision function grnd()

    implicit integer(a-z)

    !Period parameters

    parameter(N     =  624)
    parameter(N1    =  N+1)
    parameter(M     =  397)
    parameter(MATA  = -1727483681)

    !constant vector a

    parameter(UMASK = -2147483648)

    !most significant w-r bits

    parameter(LMASK =  2147483647)

    !least significant r bits

    !Tempering parameters

    parameter(TMASKB= -1658038656)
    parameter(TMASKC= -272236544)

    dimension mt(0:N-1)

    !the array for the state vector

    common /block/mti,mt
    save   /block/
    data   mti/N1/

    !mti==N+1 means mt[N] is not initialized

    dimension mag01(0:1)
    data mag01/0, MATA/
    save mag01

    !mag01(x) = x * MATA for x=0,1

    TSHFTU(y)=ishft(y,-11)
    TSHFTS(y)=ishft(y,7)
    TSHFTT(y)=ishft(y,15)
    TSHFTL(y)=ishft(y,-18)

    if(mti.ge.N) then

       !generate N words at one time

       if(mti.eq.N+1) then

          !if sgrnd() has not been called,

          call sgrnd(4357)

          !a default initial seed is used

       endif

       do  kk=0,N-M-1
          y=ior(iand(mt(kk),UMASK),iand(mt(kk+1),LMASK))
          mt(kk)=ieor(ieor(mt(kk+M),ishft(y,-1)),mag01(iand(y,1)))
       end do

       do kk=N-M,N-2
            y=ior(iand(mt(kk),UMASK),iand(mt(kk+1),LMASK))
            mt(kk)=ieor(ieor(mt(kk+(M-N)),ishft(y,-1)),mag01(iand(y,1)))
       end do

       y=ior(iand(mt(N-1),UMASK),iand(mt(0),LMASK))
       mt(N-1)=ieor(ieor(mt(M-1),ishft(y,-1)),mag01(iand(y,1)))
       mti = 0

    endif

    y=mt(mti)
    mti=mti+1
    y=ieor(y,TSHFTU(y))
    y=ieor(y,iand(TSHFTS(y),TMASKB))
    y=ieor(y,iand(TSHFTT(y),TMASKC))
    y=ieor(y,TSHFTL(y))

    if(y.lt.0) then
       grnd=(dble(y)+2.0d0**32)/(2.0d0**32-1.0d0)
    else
       grnd=dble(y)/(2.0d0**32-1.0d0)
    endif

    return
  end function grnd

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

  subroutine rangauss(sigma,mu,x1,x2)

    implicit none

    real (kind=8)    :: sigma,mu,x1,x2
    real (kind=8)    :: u1,u2,w

    do

       u1 = 2.d0*grnd()-1.d0
       u2 = 2.d0*grnd()-1.d0

       w  = u1*u1+u2*u2

       if (w<=1.d0) exit

    end do

    w = sqrt((-2.d0*log(w))/w)

    x1 = mu+sigma*u1*w
    x2 = mu+sigma*u2*w

    return
  end subroutine rangauss

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

end module random_mod


text:
      subroutine lam_print(n, sn, m, x, vr_reg, user, iuser, blo, bup,
     &     lam, f, c, nlws, lws, status)

      use interface_mod
      use nonlin_types
      implicit none

      include 'pusr.inc'
      include 'SLPCOMM.INC'

      integer n, sn, m, nlws
      integer iuser(*), vr_reg(2+2*sn+3*n), lws(nlws), status(n+m)

      double precision f
      double precision x(n), user(*), blo(n+m), bup(n+m),
     &     lam(n+m), c(m)

c     .... local variables

      integer i, ix, j, k, l, pi
      double precision viol

c     ==================== subroutine body =======================

      if (max((mi+de)*(rm+mi), (nu+1)*(mi+de)).gt.nlws) then
         write (nout,*) 'Not enough integer workspace in lamprint'
         stop
      end if

      write(nout,*)
      write(nout,*)
      write(nout,*)  ' ============= SENSITIVITY ================='
      write(nout,*)
      write(nout,*)  ' f = ',f
      write(nout,*)
      write(nout,*) 'Composition of mixers (in terms of raw materials):'
      write(nout,*)

c     ... get mu's
      do i=1,(mi+de)*(rm+mi)
         lws(i) = 0
      end do

      do i=1,n
         if (vr_reg(2+2*sn+i).eq.TYPE_MU) then
            j = vr_reg(2+2*sn+n+i)
            k = vr_reg(2+2*sn+2*n+i)
            lws((j-1)*(mi+de)+k) = i
         end if
      end do

      do j=1,mi
         write(nout,*) 'Mixer ',j
         do i=1,rm
            ix = lws((i-1)*(mi+de)+j)
            if (ix.ne.0) write(nout,'(A,I3,4F15.8,I4)')
     &           'rm-',i, blo(ix), x(ix), bup(ix), lam(ix), status(ix)
         end do
         do i=1,mi
            ix = lws((rm+i-1)*(mi+de)+j)
            if (ix.ne.0) write(nout,'(A,I3,4F15.8,I4)')
     &           'mi-',i, blo(ix), x(ix), bup(ix), lam(ix), status(ix)
         end do
      end do
      write(nout,*)
      write(nout,*)  'Composition of products (in terms of rm/mi)'
      write(nout,*)
      do j=1,de
         write(nout,*) 'Product ',j
         do i=1,rm
            ix = lws((i-1)*(mi+de)+mi+j)
            if (ix.ne.0) write(nout,'(A,I3,4F15.8,I4)')
     &           'rm-',i, blo(ix), x(ix), bup(ix), lam(ix), status(ix)
         end do
         do i=1,mi
            ix = lws((i+rm-1)*(mi+de)+mi+j)
            if (ix.ne.0) write(nout,'(A,I3,4F15.8,I4)')
     &           'mi-',i, blo(ix), x(ix), bup(ix), lam(ix), status(ix)
         end do
      end do

c     ... scan for TYPE_M variables

      do i=1,nu*(mi+de)
         lws(i) = 0
      end do
      do i=1,n
         if (vr_reg(2+2*sn+i).eq.TYPE_M) then
            j = vr_reg(2+2*sn+n+i)
            k = vr_reg(2+2*sn+2*n+i)
            lws((j-1)*(nu+1)+k) = i
         end if
         if (vr_reg(2+2*sn+i).eq.TYPE_C) then
            j = vr_reg(2+2*sn+n+i)
            if (j.ge.1)
     &           lws((j-1)*(nu+1)+nu+1) = i
         end if
      end do

      write(nout,*)
      write(nout,*)  'Composition of mixers (in terms of nutrients):'
      write(nout,*)
      do j=1,mi
         write(nout,*) 'Mixer ',j
         do i=1,nu
            ix = lws((j-1)*(nu+1)+i)
            if (ix.ne.0) write(nout,'(A,I3,4F15.8,I4)')
     &           'nu-',i, blo(ix), x(ix), bup(ix), lam(ix), status(ix)
         end do
      end do
      write(nout,*)
      write(nout,*)
     &     'Specification of products (in terms of nutrients):'
      write(nout,*)
      do k=1,de
         write(nout,*) 'Product ',k
         do l=1,nu
            ix = lws((k+mi-1)*(nu+1)+l)
            if (ix.ne.0) write(nout,'(A,I3,4F15.8,I4)')
     &           'nu-',l, blo(ix), x(ix), bup(ix), lam(ix), status(ix)
         end do
      end do

      write(nout,*)
      write(nout,*)  'Raw material percentage in Products'
      write(nout,*)
c     ... scan for TYPE_NU

      do i=1,n
         if (vr_reg(2+2*sn+i).eq.TYPE_NU) then
            j = vr_reg(2+2*sn+n+i)
            k = vr_reg(2+2*sn+2*n+i)
            if (j.le.rm) then
               if (k.le.mi) then
                  write(nout,'(A,I3,A,I3,4F15.8,I4)')
     &          'rm-',j, ': mi-',k, blo(i),x(i),bup(i),lam(i),status(ix)
               else
                  write(nout,'(A,I3,A,I3,4F15.8,I4)')
     &       'rm-',j, ': de-',k-mi, blo(i),x(i),bup(i),lam(i),status(ix)
               end if
            else
               if (k.le.mi) then
                  write(nout,'(A,I3,A,I3,4F15.8,I4)')
     &       'mi-',j-rm, ': mi-',k, blo(i),x(i),bup(i),lam(i),status(ix)
               else
                  write(nout,'(A,I3,A,I3,4F15.8,I4)')
     &    'mi-',j-rm, ': de-',k-mi, blo(i),x(i),bup(i),lam(i),status(ix)
               end if
            end if
         end if
      end do

      write(nout,*)
      write(nout,*)  'Constraints on raw material availability/'//
     &     'bin capacity'
      write(nout,*)
      do i=1,n
         if (vr_reg(2+2*sn+i).eq.TYPE_U) then
            j = vr_reg(2+2*sn+n+i)
            if (j.le.rm) then
               write(nout,'(A,I3,4F15.8)')
     &              'rm-',j, blo(i),x(i),bup(i),lam(i)
            else
               write(nout,'(A,I3,4F15.8)')
     &              'mi-',j-rm, blo(i),x(i),bup(i),lam(i)
            end if
         end if
      end do

      write(nout,*)
      write(nout,*)  'General linear constraints'
      write(nout,*)

      do i=1,m
         pi = iuser(pi_cs_pi+i)
         if (iuser(pi+6).eq.CTYPE_SPECIAL) then
            j = iuser(pi+7)
               write(nout,'(A,I3,4F15.8)')
     &             'no:',j, blo(n+i),c(i),bup(n+i),lam(n+i)
         end if
      end do

      write(nout,*)
      write(nout,*)  'Linear constraints on mixer/product composition'
      write(nout,*)

      do i=1,m
         pi = iuser(pi_cs_pi+i)
         if (iuser(pi+6).eq.CTYPE_NURAT) then
            j = iuser(pi+7)
            k = iuser(pi+8)
            if (k.lt.mi) then
               write(nout,'(A,I3,A,I3,4F15.8)')
     &             'mi-',k,' no:',j, blo(n+i),c(i),bup(n+i),lam(n+i)
            else
               write(nout,'(A,I3,A,I3,4F15.8)')
     &             'de-',k-mi,' no:',j, blo(n+i),c(i),bup(n+i),lam(n+i)
            end if
         end if
      end do

      write(nout,*)
      write(nout,*)  'General nonlinear constraints'
      write(nout,*)

      do i=m-NLD%n_cs+1,m
         write(nout,'(A,I3,4F15.8)')
     &        'no:',i+NLD%n_cs-m, blo(n+i),c(i),bup(n+i),lam(n+i)
      end do

      write(nout,*)
      write(nout,*)  'Violated constraints are:'
      write(nout,*)
      write(nout,*) ' #    TP  I  J       blo        c(i)         bup'

      do i=1,m
         pi = iuser(pi_cs_pi+i)
         viol = max(c(i)-bup(n+i), blo(n+i)-c(i))
         if (viol.gt.1.d-6) then
            write(nout,'(I4,A,3I3,3F12.5)') i,': ',
     &           iuser(pi+6), iuser(pi+7), iuser(pi+8),
     &           blo(i+n), c(i), bup(i+n)
         end if
      end do

      end

ext: f

max_stars_repo_name: ERGO-Code/FortranFilterSLP

max_issues_repo_name: ERGO-Code/FortranFilterSLP

max_forks_repo_name: ERGO-Code/FortranFilterSLP


!
!     -------------------------------------------------------------------
! *** GRAD2
!     ------------------------------------------------------------------
!
! *** THE GRAD2 FUNCTION SUBPROGRAM COMPUTES THE FOLLOWING DIRECTLY
! ***        <P(I)[R.D + F(DELTA)[ P(J)>
!
      REAL(KIND(0.0D0)) FUNCTION GRAD2 (I, J)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      use param_C
      use radial_C
      use NEL_C
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:51:26  11/20/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE quadr_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: I
      INTEGER , INTENT(IN) :: J
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: JJ, II, K, LI, LJ, IL, MM
      REAL(DOUBLE), DIMENSION(NOD) :: Q
      REAL(DOUBLE) :: A1, A2, A, FACT, G, F1, F2, G0, G1, G2, F3, &
         F4, G3, G4, U, DELTA
!-----------------------------------------------
      JJ = I
      II = J
      Q(:NO) = P(:NO,JJ)*R(:NO)
      LI = L(I)
      LJ = L(J)
      IL = IABS(LI - LJ)
      IF (IL==0 .OR. IL==2) THEN
         A1 = (LI + LJ + D2)/((LI + D1)*(LJ + D1))
         A2 = ((LJ + D5)*(LJ + D1) + (LJ + D1 + D5)*(LI + D1))/((LI + D1)*(LJ&
             + D1))
         A = A1 - A2*(LI + LJ + D3)/((LI + LJ + D4)*(LJ + D5))
         FACT = (LJ + D5)/(LI + LJ + D3)
         G = R(1)**2*P(1,I)*P(1,J)*FACT*(1. + A*Z*R(1))
         MM = MIN0(MAX_(I) + 1,MAX_(J) + 1,ND)
         K = 2
         F1 = D5*(P(K+1,II)-P(K-1,II))
         F2 = P(K+1,II) - D2*P(K,II) + P(K-1,II)
         G0 = Q(K)*R(K)
         G1 = D5*(Q(K+1)*R(K+1)-Q(K-1)*R(K-1))
         G2 = Q(K+1)*R(K+1) - D2*Q(K)*R(K) + Q(K-1)*R(K-1)
         G = G + D2*F1*G0 + (D2*F2*G1 + F1*G2)/D3
         DO K = 4, MM, 2
            F1 = D5*(P(K+1,II)-P(K-1,II))
            F2 = P(K+1,II) - D2*P(K,II) + P(K-1,II)
            F3 = D5*(P(K+1,II)-P(K-2,II)) - D2*F1
            F4 = P(K+2,II) + P(K-2,II) - D4*(P(K+1,II)+P(K-1,II)) + D6*P(K,II)
            G0 = Q(K)*R(K)
            G1 = D5*(Q(K+1)*R(K+1)-Q(K-1)*R(K-1))
            G2 = Q(K+1)*R(K+1) - D2*Q(K)*R(K) + Q(K-1)*R(K-1)
            G3 = D5*(Q(K+2)*R(K+2)-Q(K-2)*R(K-2)) - D2*G1
            G4 = Q(K+2)*R(K+2) + Q(K-2)*R(K-2) - D4*(Q(K+1)*R(K+1)+Q(K-1)*R(K-1&
               )) + D6*Q(K)*R(K)
            G = G + D2*F1*G0 + (D2*F2*G1 + F1*G2)/D3 - (F1*G4 - F4*G1 + D4*(F2*&
               G3 - F3*G2))/90.E0
         END DO
         U = QUADR(JJ,II,0)
         G = G - D5*U
         DELTA = LJ - LI
         IF (DELTA <= 0.D0) THEN
            IF (DELTA /= 0.D0) THEN
               GRAD2 = G - (LI - D2)*U
               RETURN
            ENDIF
            GRAD2 = G + (D1 + D5)*U
            RETURN
         ENDIF
         GRAD2 = G + (LI + D3)*U
         RETURN
      ENDIF
      WRITE (6, 101) I, J
  101 FORMAT(5X,'L(I)-L(J) NOT=0,2 FOR I = ',I2,' AND J = ',I2)
      STOP
      END FUNCTION GRAD2


text:
! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPmodulo_testr(
! CHECK-SAME: %[[arg0:.*]]: !fir.ref<f64>{{.*}}, %[[arg1:.*]]: !fir.ref<f64>{{.*}}, %[[arg2:.*]]: !fir.ref<f64>{{.*}}) {
subroutine modulo_testr(r, a, p)
    real(8) :: r, a, p
    ! CHECK-DAG: %[[a:.*]] = fir.load %[[arg1]] : !fir.ref<f64>
    ! CHECK-DAG: %[[p:.*]] = fir.load %[[arg2]] : !fir.ref<f64>
    ! CHECK-DAG: %[[rem:.*]] = arith.remf %[[a]], %[[p]] : f64
    ! CHECK-DAG: %[[zero:.*]] = arith.constant 0.000000e+00 : f64
    ! CHECK-DAG: %[[remNotZero:.*]] = arith.cmpf une, %[[rem]], %[[zero]] : f64
    ! CHECK-DAG: %[[aNeg:.*]] = arith.cmpf olt, %[[a]], %[[zero]] : f64
    ! CHECK-DAG: %[[pNeg:.*]] = arith.cmpf olt, %[[p]], %[[zero]] : f64
    ! CHECK-DAG: %[[signDifferent:.*]] = arith.xori %[[aNeg]], %[[pNeg]] : i1
    ! CHECK-DAG: %[[mustAddP:.*]] = arith.andi %[[remNotZero]], %[[signDifferent]] : i1
    ! CHECK-DAG: %[[remPlusP:.*]] = arith.addf %[[rem]], %[[p]] : f64
    ! CHECK: %[[res:.*]] = arith.select %[[mustAddP]], %[[remPlusP]], %[[rem]] : f64
    ! CHECK: fir.store %[[res]] to %[[arg0]] : !fir.ref<f64>
    r = modulo(a, p)
  end subroutine

  ! CHECK-LABEL: func @_QPmodulo_testi(
  ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<i64>{{.*}}, %[[arg1:.*]]: !fir.ref<i64>{{.*}}, %[[arg2:.*]]: !fir.ref<i64>{{.*}}) {
  subroutine modulo_testi(r, a, p)
    integer(8) :: r, a, p
    ! CHECK-DAG: %[[a:.*]] = fir.load %[[arg1]] : !fir.ref<i64>
    ! CHECK-DAG: %[[p:.*]] = fir.load %[[arg2]] : !fir.ref<i64>
    ! CHECK-DAG: %[[rem:.*]] = arith.remsi %[[a]], %[[p]] : i64
    ! CHECK-DAG: %[[argXor:.*]] = arith.xori %[[a]], %[[p]] : i64
    ! CHECK-DAG: %[[signDifferent:.*]] = arith.cmpi slt, %[[argXor]], %c0{{.*}} : i64
    ! CHECK-DAG: %[[remNotZero:.*]] = arith.cmpi ne, %[[rem]], %c0{{.*}} : i64
    ! CHECK-DAG: %[[mustAddP:.*]] = arith.andi %[[remNotZero]], %[[signDifferent]] : i1
    ! CHECK-DAG: %[[remPlusP:.*]] = arith.addi %[[rem]], %[[p]] : i64
    ! CHECK: %[[res:.*]] = arith.select %[[mustAddP]], %[[remPlusP]], %[[rem]] : i64
    ! CHECK: fir.store %[[res]] to %[[arg0]] : !fir.ref<i64>
    r = modulo(a, p)
  end subroutine

max_stars_repo_name: akashhansda/llvm-project

max_issues_repo_name: akashhansda/llvm-project

max_forks_repo_name: akashhansda/llvm-project


text:
      MODULE start_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.3E  10:50:48   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      SUBROUTINE start (IORB, ITYPE, P0, P, Q0, Q)
      USE vast_kind_param,ONLY: DOUBLE
      USE parameter_def,   ONLY: NNNP
      INTEGER, INTENT(IN) :: IORB
      INTEGER, INTENT(IN) :: ITYPE
      REAL(DOUBLE), INTENT(IN) :: P0
      REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P
      REAL(DOUBLE), INTENT(OUT) :: Q0
      REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q
!VAST.../CNC6/ CNC6C(IN)
!VAST.../DEF1/ Z(IN)
!VAST.../DEF2/ C(IN)
!VAST.../DEF4/ ACCY(IN)
!VAST.../GRID/ R(IN), RP(IN)
!VAST.../NPAR/ NPARM(IN)
!VAST.../ORB1/ E(IN), GAMA(IN)
!VAST.../ORB4/ NP(IN), NAK(IN)
!VAST.../ORB10/ NH(IN)
!VAST.../POTE/ YP(IN), XP(IN), XQ(IN)
!VAST.../SCF2/ NDCOF(IN)
!VAST.../WAVE/ PZ(IN)
!VAST...Calls: NDA, DA, QF, PF
!...This routine performs I/O.
      END SUBROUTINE
      END INTERFACE
      END MODULE

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
      subroutine sobel(n,nrowc,ncolc,c,jc,ic,a,ja,ia,b,jb,ib,nzmax,ierr)
      integer i, n, ia(*), ja(*), ib(*), jb(*)
      integer nrowa, ncola, nrowb, ncolb, nrowc, ncolc, ipos
      integer ic(*), jc(*), offset, ierr
      real*8  a(*), b(*), c(*)
c-----------------------------------------------------------------------
c     This subroutine generates a matrix used in the statistical problem
c     presented by Prof. Sobel. The matrix is formed by a series of
c     small submatrix on or adjancent to the diagonal. The submatrix on
c     the diagonal is square and the size goes like 1, 1, 2, 2, 3, 3,...
c     Each of the diagonal block is a triadiagonal matrix, each of the
c     off-diagonal block is a bidiagonal block. The values of elements
c     in the off-diagonal block are all -1. So are the values of the
c     elements on the sub- and super-diagonal of the blocks on the
c     diagonal. The first element(1,1) of the diagonal block is alternating
c     between 3 and 5, the rest of the diagonal elements (of the block
c     on the diagonal) are 6.
c-----------------------------------------------------------------------
c     This subroutine calls following subroutines to generate the three
c     thypes of submatrices:
c     diagblk -- generates diagonal block.
c     leftblk -- generates the block left of the diagonal one.
c     rightblk-- generates the block right of the diagonal one.
c-----------------------------------------------------------------------
      if (n.lt.2) return

      ipos = 1
      offset = 1
      call diagblk(1, nrowc, ncolc, c, jc, ic)
      do 10 i=2, n-2
         nrowa = nrowc
         ncola = ncolc
         call copmat (nrowc,c,jc,ic,a,ja,ia,1,1)
         call rightblk(i-1, nrowb, ncolb, b,jb,ib)
         call addblk(nrowa,ncola,a,ja,ia,ipos,ipos+offset,1,
     $        nrowb,ncolb,b,jb,ib,nrowc,ncolc,c,jc,ic,nzmax,ierr)
         call leftblk(i,nrowb,ncolb,b,jb,ib)
         call addblk(nrowc,ncolc,c,jc,ic,ipos+offset,ipos,1,
     $        nrowb,ncolb,b,jb,ib,nrowa,ncola,a,ja,ia,nzmax,ierr)
         ipos = ipos + offset
         call diagblk(i,nrowb,ncolb,b,jb,ib)
         call addblk(nrowa,ncola,a,ja,ia,ipos,ipos,1,
     $        nrowb,ncolb,b,jb,ib,nrowc,ncolc,c,jc,ic,nzmax,ierr)
         offset = 1 + (i-1)/2
 10   continue
      end
c-----------------------------------------------------------------------
      subroutine diagblk(n, nrow, ncol, a, ja, ia)
      implicit none
      integer n, nrow, ncol, ia(1:*), ja(1:*)
      real*8  a(1:*)
c-----------------------------------------------------------------------
c     generates the diagonal block for the given problem.
c-----------------------------------------------------------------------
      integer i, k
      nrow = 1 + (n-1)/2
      ncol = nrow
      k = 1
      ia(1) = 1
      ja(1) = 1
      if (mod(n, 2) .eq. 1) then
         a(1) = 3
      else
         a(1) = 5
      end if
      k = k + 1
      if (ncol.gt.1) then
         ja(2) = 2
         a(2) = -1.0
         k = k + 1
      end if

      do 10 i = 2, nrow
         ia(i) = k
         ja(k) = i-1
         a(k) = -1.0
         k = k + 1
         ja(k) = i
         a(k) = 6.0
         k = k + 1
         if (i.lt.nrow) then
            ja(k) = i + 1
            a(k) = -1.0
            k = k+1
         end if
 10   continue
      ia(nrow+1) = k
      return
c---------end-of-diagblk------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine leftblk(n, nrow, ncol, a, ja, ia)
      implicit none
      integer n, nrow, ncol, ja(1:*), ia(1:*)
      real*8  a(1:*)
c-----------------------------------------------------------------------
c     Generate the subdiagonal block for the problem given.
c-----------------------------------------------------------------------
      integer i, k
      nrow = 1 + (n-1)/2
      ncol = n/2
      k = 1
      do 10 i = 1, nrow
         ia(i) = k
         if (nrow.ne.ncol) then
            if (i.gt.1) then
               ja(k) = i-1
               a(k) = -1.0
               k = k+1
            end if
         end if
         if (i.le.ncol) then
            ja(k) = i
            a(k) = -1.0
            k = k+1
         end if
         if (nrow.eq.ncol) then
            if (i.lt.ncol) then
               ja(k) = i+1
               a(k) = -1.0
               k = k+1
            end if
         end if
 10   continue
      ia(nrow+1) = k
      return
c---------end-of-leftblk------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine rightblk(n, nrow, ncol, a, ja, ia)
      implicit none
      integer n, nrow, ncol, ja(1:*), ia(1:*)
      real*8  a(1:*)
      integer i, k
      nrow = 1 + (n-1)/2
      ncol = 1 + n/2
      k = 1
      do 10 i = 1, nrow
         ia(i) = k
         if (nrow.eq.ncol) then
            if (i.gt.1) then
               ja(k) = i-1
               a(k) = -1.0
               k = k+1
            end if
         end if
         ja(k) = i
         a(k) = -1.0
         k = k+1
         if (nrow.ne.ncol) then
            ja(k) = i+1
            a(k) = -1.0
            k = k+1
         end if
 10   continue
      ia(nrow+1) = k
c---------end-of-rightblk-----------------------------------------------
      end

max_stars_repo_name: xywei/Mirana

max_issues_repo_name: xywei/Mirana

max_forks_repo_name: xywei/Mirana


text:
REAL*8 function kern_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
kern_num = sin(x_a - x_b)
end function
REAL*8 function dkdx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx_num = cos(x_a - x_b)
end function
INTEGER*4 function dkdy_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy_num = 0
end function
REAL*8 function dkdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx0_num = -cos(x_a - x_b)
end function
INTEGER*4 function dkdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy0_num = 0
end function
REAL*8 function d2kdxdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdx0_num = sin(x_a - x_b)
end function
INTEGER*4 function d2kdydy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdydy0_num = 0
end function
INTEGER*4 function d2kdxdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdy0_num = 0
end function
INTEGER*4 function d3kdxdx0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dy0_num = 0
end function
INTEGER*4 function d3kdydy0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dy0_num = 0
end function
INTEGER*4 function d3kdxdy0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dy0_num = 0
end function
INTEGER*4 function dkdlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdlx_num = 0
end function
INTEGER*4 function dkdly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdly_num = 0
end function
INTEGER*4 function d3kdxdx0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dlx_num = 0
end function
INTEGER*4 function d3kdydy0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dlx_num = 0
end function
INTEGER*4 function d3kdxdy0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dlx_num = 0
end function
INTEGER*4 function d3kdxdx0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dly_num = 0
end function
INTEGER*4 function d3kdydy0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dly_num = 0
end function
INTEGER*4 function d3kdxdy0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dly_num = 0
end function

max_stars_repo_name: krystophny/profit

max_issues_repo_name: krystophny/profit

max_forks_repo_name: krystophny/profit


text:
Some local artists of renown include: (listed alphabetically)

  Jed Alexander Artist and illustrator. You can see his work at http://jedalexander.com
  http://www.natsoulas.com/html/artists/robertArneson/robertArneson.html Robert Arneson  Former Art Department Art Faculty at UCD
  http://www.verisimilitudo.com/arneson Robert Arneson tribute site
  Conrad Atkinson
  http://www.chilltree.com/ Emily Barranco Earlenbaugh (Chill Tree Jewelry)  Custom Art and Jewelry by Donation.
  http://www.cuteware.net Heidi Bekebrede Ceramicist, vocalist, The Artery Artery member since 1988.
  Kris Bell Artist, portrait and figure painter, kristhebell.blogspot.com
  Donna Billick Tile and ceramics
  Jill Bowlus  Artist/Art Educator, Ceramics  http://www.atheartart.com
  http://www.marietheresebrown.com MarieTherese Brown painter The Artery Artery
  Deborah Butterfield (B.A. 1971, M.F.A. 1973)
  http://www.jamesharrisgallery.com/Artists/Squeak%20Carnwrath/carnwrath.htm Squeak Carnwath  Former Art Department Art Faculty at UCD (now at UC Berkeley UC Berkeley)
  http://www.melissachandon.com/ Melissa Chandon
  http://www.tvcarrera.com/ Tracy Villa Carrera, http://www.carnahanfineart.com/products.cfm?ArtistID6&CatID3 profile
  http://www.lynnecunningham.com Lynne Cunningham painter, public art, instructor also here:Users/LynneCunningham  Lynne Cunningham
  Users/DianaJahns Diana Jahns  painter and photographer
  http://modernsculpture.com/deforest.php Roy DeForest  Former Art Department Art Faculty at UCD
  Users/TorreyaCummings Torreya Cummings Not famous, but damn good.
  Users/JasonDayne Jason Dayne  Jeeba Jewelry  http://www.jeeba.com Handcrafted jewelry in sterling silver with gemstones.
  Jesse Drew  Media artist. Associate Director of Technocultural Studies at UCD.
  Arlen FeldwickJones
  Henna by Funo Funo  henna artist from Sudan
  Users/PhilGeck  Tattoo Artist/ artists, diverse in Oil, Acrylic and water color. works at http://daviswiki.org/Primary_Concepts_Tattooing?actionshow&redirectPrimary+Concepts/ Primary Concepts in downtown Davis.
  http://www.davidgilhooly.com/ David Gilhooly  Famous for his funk ceramics. Now does paintings.
  Users/DanGlendening Daniel J. Glendening  famous. nuff said.
  http://www.philgross.net/ Phil Gross Painter of  Sacramento valley and Northern California Landscapes
  Users/GeraldHeffernon Gerald Heffernon  created the Davis Food Coop Tomato
  http://hollowell.ucdavis.edu/ David Hollowell  Current Art Department Art Faculty at UCD
  http://www.rasehallstudios.com/blog/archives/000970.html Steve Kaltenbach Conceptualist MFA UC Davis  studied with Wiley and Nauman (also http://www.lawrencemarkey.com/kaltenbach_w.htm click here)
  http://www.krop.com/katykhotography/ Katy Karns Photographer, also starts EC Garden Art Walks http://www.facebook.com/profile.php?refprofile&id100000620017970
  Tim Lane  contemporary artist painterhttp://www.timothylaneart.com/   http://www.myspace.com/flowersinspace
  http://www.natsoulas.com/html/artists/williamMaul/williamMaul.html William Maul  Artist
  http://www.tonynatsoulas.com Tony Natsoulas  Raised in Davis and went to UCD for BA and MFA. Made sculptures of The Joggers Joggers Downtown (and much more).
  http://www.urbangoddessdesigns.com/ Lisa Novotny  Jewelry designer
  Jeffrey Blake Palmer  artist, filmmaker, radio & media guy  http://flickerpictures.com
  http://paradox.rambisyouth.com  Local artist who did a large Burroughs style cut up collage.
  http://archivesofamericanart.si.edu/oralhist/peters02.htm Roland Petersen
  http://www.lucypuls.com/ Lucy Puls  Art Department Chair at UCD
  Users/Pxlated  Urban Art and http://www.flickr.com/photos/benignpxl political collage.
  http://www.urbangoddessdesigns.com/ Misty Reed  Jewelry, lampwork & graphic designer
  http://nomanrileyphotography.com Norman E. Riley Large Format Photography
  Mark Rivera Tile and ceramics
  Kerry RowlandAvrech Painter and muralist
  http://www.transitlounge.com/hassel_smith/ Hassel Smith
  http://wwwenglish.ucdavis.edu/faculty/snyder/snyder.htm Gary Snyder
  Users/ConnieTaxiera Connie Taxiera  Piece of Mind Fabrications  http://fabricartbyconnie.com Fabric art bowls by Connie.
  Wayne Thiebaud  Emeritus Art Department Art Faculty at UCD
  Jean Van Keuren  Ceramics, Bronzes, and Cement sculptures  http://www.jeanvankeuren.com Jean Van Keuren Made Greenbelt Dogs, Senior Center Bronze, Cement Giraffe by Hallmark Inn
  Daryl R. Vasquez  Owner of Aesthetic Reflections: commissioned portraits
  Tom Dotan and John King created The UC Davis Show, a Daviscentric sitcom.  There appears to have only been a pilot episode.
  http://www.facebook.com/sotoodeh.yarmahmoudi Sotoodeh Yarmahmoudi  Artist, Illustrator and Character Designer. You can see her artworks at her http://www.sotoodehyari.com/ website.
  Kirsten Elise Young users/Kirstenelise  http://kirsteneyoung.viewbook.com/

Some of these open their studios for the Davis Artist Studio Tour.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
Roman Rivilis is a candidate in the Winter 2013 ASUCD Election, running as an independent.

Roman is a secondyear political science major from San Jose, California. He has been involved with a number of campus organizations including Model United Nations at UC Davis and Debate at Davis. He is an Internal Affairs Commission member, serving as both a voting member and alternate. He is actively involved in Greek Life and is a brother of the Chi Phi fraternity.

 Candidate Statement

Hello Aggies!

My name is Roman Rivilis, and I am a secondyear Political Science major from the Bay Area. I want to adapt the association to serve the students more closely. I plan to foster the involvement and opportunities of the student body, in order to further enrich the educational experiences of Davis students as well as sustain the budget needed to support these students.

EXPERIENCE:
 Intern to Senator Justin Goss
 Internal Affairs Commissioner
 Lobby Corps Intern
 Entertainment Council Volunteer
 KDVS Volunteer

IMPROVE BUSINESS INFRASTRUCTURE
ASUCDs budget has been dwindling as of late. Funding primarily goes to units which derive from student fees, but theres no financial mechanism that can effectively accommodate both the ASUCD budget and student fees. Students already have a difficult time affording textbooks, and with the absence of US Bank from the campus, the need of a reliable business unit has escalated. By working with Brett Burns, the ASUCD Business Manager, and contacting the Student Alumni Association, I plan to institutionalize a student and alumni credit union that engages in microcrediting practices, allowing students to withdraw loans to purchase textbooks at low interest rates.  ASUCD’s budget can gradually grow in the long run, and students will have financial relief and management experience in the short run.

CONNECT FACULTY TO STUDENT ORGANIZATIONS
There are over 1800 faculty members on campus and 25,000 students; this number continues to grow, fostering the need for student organizations throughout UC Davis. There are a diverse range of clubs and organizations on campus, all of which offer great chances for students to get involved, but many of these clubs lack consistent means to communicate with members of faculty willing to support their organization. By collaborating with faculty advisors and ASUCD Outreach Assembly, I plan to organize a sponsorship program that connects members of the faculty with clubs and student organizations. Students will be able to build rapport with faculty and gain valuable internship, networking, and even research opportunities among other advantages by directly networking instructors and other staff with students on campus.

RESTORE THE AS PAPERS AS AN ONLINE UNIT
With the passage of the 20/20 Initiative looming over, thousands of students will be expected to pour into the campus over time, increasing the need of oncampus representation and expression. AS Papers, a unit last seen in 2011, provided this representation by comprising over a dozen different publications at the behest of the student body. Unfortunately, misuse of the AS Papers office by the student body rendered a unit an oncampus computer lab, which diminished its use over time until the unit was closed. I plan to collaborate with Alex Park, the Creative Media director, to reinstate AS Papers into an ASUCDsponsored website that allows for the circulation of numerous campus editorials, increasing the input of opinions presented by the student body and fostering the involvement of a gradual influx of students.

VOTE ROMAN RIVILIS #1 FOR ASUCD SENATE!
VOTE MIN AND CANO #1 EXEC!
VOTE FEBRUARY 1922 AT http://elections.ucdavis.edu


text:
	!> Element that solves the trivial diagonal problem of incrementing variables
	!! @param CommonPar = ( a , a*[bi,ci,di,ei] , dummy ) where :
	!! @param Nvar = CommonPar(1) ==> a
	!! @param iShiftUi = CommonPar(see structure) ===> bi
	!! @param iShiftDeltaUi = CommonPar(see structure) ===> ci
	!! @param nodei (for each material = see structure) ===> ei
	!! @author Rocha, Felipe Figueredo

!! last update: lenU given by parameter and not by difference between iShiftU and iShiftDeltaU. NodMax is given, rather than assumed
Subroutine IncrementVariables_Conditional(AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, &
											Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)
!     ------------------------------------------------------------------

	use funcAux
	use TIME_STEP_ITER
	implicit none

	!   ===== SUBROUTINE ARGUMENTS  =======
	integer :: MaxLRows,Ndim,iDofT,NodELT ! all integers
	Real*8 :: DelT, DTm,Time ! all reals
	Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

	!   =====   END ARGUMENTS  =======

    integer , parameter :: NauxParam = 5
    integer :: Nvar, iShiftDeltaU, iShiftU, lenU, node, NodMax , node1, node2, enableConditional
    integer :: i, ip, jp, jpDelta, j, k

	Nvar = nint(commonPar(1))
	NodMax = nint(commonPar(2))

	do i = 1 , Nvar
		ip = (i-1)*NauxParam + 2
		iShiftU = nint(commonPar(ip + 1))
		iShiftDeltaU = nint(commonPar(ip + 2))
		node = nint(commonPar(ip + 3))
		lenU = nint(commonPar(ip + 4))
		enableConditional = nint(commonPar(ip + 5))

		if(node == 0) then
			node1 = 1
			node2 = NodMax
		else
			node1 = node
			node2 = node
		end if

		do j = node1,node2
			jp = (j - 1)*iDofT + iShiftU
			jpDelta = (j - 1)*iDofT + iShiftDeltaU

			do k = 1,lenU
				AE(jp + k, jp + k) = 1.0d0
				if(Nconverg == 1 .and. enableConditional == 1) then
					BE(jp + k) = Sol1(jpDelta + k)
				else
					BE(jp + k) = Sol1(jpDelta + k) + Sol1(jp + k)
				end if
			end do
		end do

	end do

End subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine IncrementVariables_ConditionalS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	use funcAux
	IMPLICIT NONE
	Integer :: MaxLRows,Ndim,iDofT, iAdd, ipRow
	Integer   Coupling(MaxLRows,MaxLRows)
	Real*8 CommonPar(*)

    integer , parameter :: NauxParam = 5
    integer :: Nvar, iShiftDeltaU, iShiftU, lenU, node, NodMax , node1, node2
    integer :: i, ip, jp, jpDelta, j, k

	Nvar = nint(commonPar(1))
	NodMax = nint(commonPar(2))

	do i = 1 , Nvar
		ip = (i-1)*NauxParam + 2
		iShiftU = nint(commonPar(ip + 1))
		iShiftDeltaU = nint(commonPar(ip + 2))
		node = nint(commonPar(ip + 3))
		lenU = nint(commonPar(ip + 4))

		if(node == 0) then
			node1 = 1
			node2 = NodMax
		else
			node1 = node
			node2 = node
		end if

		do j = node1,node2
			jp = (j - 1)*iDofT + iShiftU
			jpDelta = (j - 1)*iDofT + iShiftDeltaU

			do k = 1,lenU
				Coupling(jp + k, jp + k) = 1
			end do
		end do

	end do

!~ 	call numprint(Coupling)
!~ 	pause
end Subroutine

max_stars_repo_name: felipefr/gpmaterials

max_issues_repo_name: felipefr/gpmaterials

max_forks_repo_name: felipefr/gpmaterials


text:
      SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  CUNMR2 overwrites the general complex m-by-n matrix C with
*
*        Q * C  if SIDE = 'L' and TRANS = 'N', or
*
*        Q'* C  if SIDE = 'L' and TRANS = 'C', or
*
*        C * Q  if SIDE = 'R' and TRANS = 'N', or
*
*        C * Q' if SIDE = 'R' and TRANS = 'C',
*
*  where Q is a complex unitary matrix defined as the product of k
*  elementary reflectors
*
*        Q = H(1)' H(2)' . . . H(k)'
*
*  as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n
*  if SIDE = 'R'.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply Q or Q' from the Left
*          = 'R': apply Q or Q' from the Right
*
*  TRANS   (input) CHARACTER*1
*          = 'N': apply Q  (No transpose)
*          = 'C': apply Q' (Conjugate transpose)
*
*  M       (input) INTEGER
*          The number of rows of the matrix C. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C. N >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines
*          the matrix Q.
*          If SIDE = 'L', M >= K >= 0;
*          if SIDE = 'R', N >= K >= 0.
*
*  A       (input) COMPLEX array, dimension
*                               (LDA,M) if SIDE = 'L',
*                               (LDA,N) if SIDE = 'R'
*          The i-th row must contain the vector which defines the
*          elementary reflector H(i), for i = 1,2,...,k, as returned by
*          CGERQF in the last k rows of its array argument A.
*          A is modified by the routine but restored on exit.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,K).
*
*  TAU     (input) COMPLEX array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i), as returned by CGERQF.
*
*  C       (input/output) COMPLEX array, dimension (LDC,N)
*          On entry, the m-by-n matrix C.
*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDC >= max(1,M).
*
*  WORK    (workspace) COMPLEX array, dimension
*                                   (N) if SIDE = 'L',
*                                   (M) if SIDE = 'R'
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, MI, NI, NQ
      COMPLEX            AII, TAUI
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLACGV, CLARF, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
*
*     NQ is the order of Q
*
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CUNMR2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
     $   RETURN
*
      IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
         I1 = 1
         I2 = K
         I3 = 1
      ELSE
         I1 = K
         I2 = 1
         I3 = -1
      END IF
*
      IF( LEFT ) THEN
         NI = N
      ELSE
         MI = M
      END IF
*
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
*
*           H(i) or H(i)' is applied to C(1:m-k+i,1:n)
*
            MI = M - K + I
         ELSE
*
*           H(i) or H(i)' is applied to C(1:m,1:n-k+i)
*
            NI = N - K + I
         END IF
*
*        Apply H(i) or H(i)'
*
         IF( NOTRAN ) THEN
            TAUI = CONJG( TAU( I ) )
         ELSE
            TAUI = TAU( I )
         END IF
         CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA )
         AII = A( I, NQ-K+I )
         A( I, NQ-K+I ) = ONE
         CALL CLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK )
         A( I, NQ-K+I ) = AII
         CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA )
   10 CONTINUE
      RETURN
*
*     End of CUNMR2
*
      END

max_stars_repo_name: IRFM/ALOHA

max_issues_repo_name: IRFM/ALOHA

max_forks_repo_name: IRFM/ALOHA


text:
      SUBROUTINE dbt( wdepth )
c     Parse a NMEA $DBT (depth below transducer) string and return
c  it as the water depth in meters.
c    e.g.  $DBT,0017.6,f,0005.4,M
c          $SDDBT,,,3807.,M,,*2A
c
c   Paul Henkart, Scripps Institution of Oceanography, October 2006
c
c
      CHARACTER*82 out
      SAVE wdepth_last
      DATA wdepth_last/0./

      wdepth = 0.
c**** token 1 is $DBT or $dbt
      CALL getokec( out, nchars )
      CALL getokec( out, nchars )
      CALL getokec( out, nchars )
      CALL getokec( out, nchars )
      IF( nchars .GT. 0 ) CALL dcode( out, nchars, wdepth, istat )
      IF( wdepth .LE. 0 ) wdepth = wdepth_last
      wdepth_last = wdepth
c**** Don't call getoke for the last field because it may not be terminated
      RETURN
      END

max_stars_repo_name: apthorpe/sioseis

max_issues_repo_name: henkart/sioseis

max_forks_repo_name: henkart/sioseis


text:
subroutine max_ovr (nlon_i, nlat_i, numlon_i, nlon_o, nlat_o, numlon_o, &
                    lon_i , lat_i , lon_o   , lat_o , novr_max)

  use precision

! -----------------------------------------------------------------
  implicit none
! ------------------------ code history ---------------------------
! source file:       max_ovr
! purpose:           determine maximum number of overlapping cells
!                    input and output grids
! date last revised: March 1997
! author:            Mariana Vertenstein
! standardized:
! reviewed:
! -----------------------------------------------------------------

! ------------------- input variables -----------------------------
  integer, intent(in)  :: nlon_i                 !number of input  longitude points
  integer, intent(in)  :: nlat_i                 !number of input  latitude points
  integer, intent(in)  :: numlon_i(nlat_i)       !number of longitude points for each input grid cell latitude
  integer, intent(in)  :: nlon_o                 !number of output longitude points
  integer, intent(in)  :: nlat_o                 !number of output latitude points
  integer, intent(in)  :: numlon_o(nlat_o)       !number of longitude points for each output grid cell latitude
  real(r8), intent(in) :: lon_i(nlon_i+1,nlat_i) !input grid cell longitude, western edge
  real(r8), intent(in) :: lat_i(nlat_i+1)        !input grid cell latitude, southern edge
  real(r8), intent(in) :: lon_o(nlon_o+1,nlat_o) !output grid cell longitude, western edge
  real(r8), intent(in) :: lat_o(nlat_o+1)        !output grid cell latitude , southern edge
  integer , intent(out):: novr_max               !maximum number of overlapping input cells
! -----------------------------------------------------------------

! ------------------- local variables -----------------------------
  integer novr                !number of overlapping input cells
  integer io,ii               !output and input grids longitude loop index
  integer jo,ji               !output and input grids latitude  loop index
! -----------------------------------------------------------------

! -----------------------------------------------------------------
! for each output grid cell: find overlapping input grid cell and area of
! input grid cell that overlaps with output grid cell. cells overlap if:
!
! southern edge of input grid < northern edge of output grid AND
! northern edge of input grid > southern edge of output grid
!
! western edge of input grid < eastern edge of output grid AND
! eastern edge of input grid > western edge of output grid
!
!           lon_o(io,jo)       lon_o(io+1,jo)
!
!              |                   |
!              --------------------- lat_o(jo+1)
!              |                   |
!              |                   |
!    xxxxxxxxxxxxxxx lat_i(ji+1)   |
!    x         |   x               |
!    x  input  |   x   output      |
!    x  cell   |   x    cell       |
!    x  ii,ji  |   x   io,jo       |
!    x         |   x               |
!    x         ----x---------------- lat_o(jo  )
!    x             x
!    xxxxxxxxxxxxxxx lat_i(ji  )
!    x             x
! lon_i(ii,ji) lon_i(ii+1,ji)
! -----------------------------------------------------------------

!
! determine maximum number of overlapping cells
! loop through all input grid cells to find overlap with output grid.
! code does not vectorize but is only called during initialization.
!
  novr_max = 0
  do jo = 1, nlat_o
    do io = 1, numlon_o(jo)
      novr = 0
      do ji = 1, nlat_i
        if (lat_i(ji  ).lt.lat_o(jo+1) .and. &
            lat_i(ji+1).gt.lat_o(jo  )) then  !lat ok
          do ii = 1, numlon_i(ji)
            if (lon_i(ii  ,ji).lt.lon_o(io+1,jo) .and. &
                lon_i(ii+1,ji).gt.lon_o(io  ,jo)) then !lon okay
              novr = novr + 1    ! increment number of ovrlap cells for io,jo
            end if
          end do
        end if
      end do
      if (novr .gt. novr_max) novr_max = novr
    end do
  end do

  return
end subroutine max_ovr

max_stars_repo_licenses: zlib-acknowledgement FTL RSA-MD

max_issues_repo_licenses: zlib-acknowledgement FTL RSA-MD

max_forks_repo_licenses: zlib-acknowledgement FTL RSA-MD


text:
C
C	$Id: ngckop.f,v 1.4 2008-07-27 00:17:17 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      INTEGER FUNCTION NGCKOP(IWKID)
C
C  Function to check if the workstation, whose workstation ID is
C  given in IWKID, is currently open.  If it is open, then the
C  function returns a 1, otherwise the function returns a 0.
C
      CALL GQOPWK(0,IER,NOPN,LID)
      IF (NOPN .EQ. 0) THEN
        NGCKOP = 0
        RETURN
      ELSE
        DO 10 I=1,NOPN
          CALL GQOPWK(I,IER,NOPN,LID)
          IF (IWKID .EQ. LID) THEN
            NGCKOP = 1
            RETURN
          ENDIF
   10   CONTINUE
      ENDIF
C
      NGCKOP = 0
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
!>------------------------------------------------
!! Defines the interface for a variable dictionary
!!
!! Dictionary can be accessed by string keys
!! Dictionary stores variable_t types
!!
!!------------------------------------------------

module variable_dict_interface
    ! variable type to store... this could be made unlimited but that complicates use
    use variable_interface,     only : variable_t
    use icar_constants

    !>------------------------------------------------
    !! Defines the object that is actually stored in the dictionary array
    !!
    !! This object stores the key-value pair and can also store an associated variable
    !!
    !!------------------------------------------------
    type var_dict_element
        character(len=kMAX_NAME_LENGTH) :: name         ! serves as the dictionary key
        type(variable_t)                :: var          ! store the primary dictionary variable for the key name
        type(variable_t)                :: domain_var   ! store the associated dictionary variable
    end type

    !>------------------------------------------------
    !! Defines the dictionary
    !!
    !! Primarily and array of dictionary elements
    !!
    !! Methods are defined to add to the dictionary and retrieve from it
    !! Note that there is no way to remove objects from the dictionary at present
    !! Also that the routines to work with an associated variable (domain_var) are not implemented yet
    !!
    !!------------------------------------------------
    type var_dict_t
        ! this is the primary data structure that holds the dictionary data
        type(var_dict_element), allocatable :: var_list(:)

        ! used to iterate through variables in dictionary
        integer :: current_variable

        ! keep track of how many variables we have stored
        integer :: n_vars = 0
        ! keep track of how many variables we are able to store (== size(var_list))
        integer :: max_vars = 0

        ! keep track of wheather or not this dictionary has been initialized yet or not
        logical :: initialized = .False.

    contains
        procedure :: reset_iterator     ! reset internal counters to make it possible to iterate over elements
        procedure :: has_more_elements  ! test if there are more elements to iterate over still
        procedure :: next               ! continue iterating through array elements
        procedure :: get_var            ! get a variable for a given key
        procedure :: add_var            ! store a variable with a given key
        procedure :: get_domain_var     ! get the associated domain variable for a key
        procedure :: set_domain_var     ! set the associated domain variable for a key

        procedure :: init               ! initialize the dictionary (e.g. allocate the var_list)
    end type

interface

    !>------------------------------------------------
    !! Additional documentation provided in the associated object implementation
    !!
    !!------------------------------------------------

    module subroutine init(this)
        implicit none
        class(var_dict_t),   intent(inout)  :: this
    end subroutine

    !>-------------------------
    !! Module subroutines for managing the dictionary as an iterator
    !!
    !!-------------------------
    module subroutine reset_iterator(this)
        implicit none
        class(var_dict_t),   intent(inout)  :: this
    end subroutine

    module function has_more_elements(this) result(boolean)
        implicit none
        class(var_dict_t),   intent(in) :: this
        logical :: boolean
    end function

    module function next(this, name, err) result(var_data)
        implicit none
        class(var_dict_t),   intent(inout)  :: this
        character(len=*),    intent(out),   optional :: name
        integer,             intent(out),   optional :: err
        type(variable_t)                    :: var_data
    end function

    !>-------------------------
    !! Primary subroutines to add and retrieve elements
    !!
    !!-------------------------
    module function get_var(this, varname, err) result(var_data)
        implicit none
        class(var_dict_t),   intent(in) :: this
        character(len=*),    intent(in) :: varname
        integer,             intent(out),   optional :: err
        type(variable_t)                :: var_data
    end function

    module subroutine add_var(this, varname, var_data, domain_var, save_state, err)
        implicit none
        class(var_dict_t),   intent(inout)  :: this
        character(len=*),    intent(in)     :: varname
        type(variable_t),    intent(in)     :: var_data
        type(variable_t),    intent(in), optional :: domain_var
        logical,             intent(in), optional :: save_state
        integer,             intent(out),optional :: err
    end subroutine

    module function get_domain_var(this, varname) result(var_data)
        implicit none
        class(var_dict_t),   intent(in) :: this
        character(len=*),    intent(in) :: varname
        type(variable_t),    pointer    :: var_data
    end function

    module subroutine set_domain_var(this, varname, var_data)
        implicit none
        class(var_dict_t),   intent(inout)  :: this
        character(len=*),    intent(in)     :: varname
        type(variable_t),    intent(in)     :: var_data
    end subroutine

end interface

end module

max_stars_repo_name: scrasmussen/icar

max_issues_repo_name: scrasmussen/icar

max_forks_repo_name: scrasmussen/icar