text:
	SUBROUTINE GG_TLBL ( np, rlat, rlon, alat, alon, iret )
C************************************************************************
C* GG_TLBL								*
C*									*
C* This subroutine gets the location of the text label for current      *
C* Convective Sigmets and Convective Outlook bounded areas.  The        *
C* location is the topmost point of the area.  				*
C*									*
C* GG_TLBL ( NP, RLAT, RLON, ALAT, ALON, IRET )                         *
C*									*
C* Input parameters:							*
C*	NP  		INTEGER		Number of points                *
C*	RLAT (*)	REAL		Latitudes of points             *
C*	RLON (*)	REAL		Longitudes of points            *
C*									*
C* Output parameters:							*
C*	ALAT 		REAL		Latitude of label               *
C*	ALON 		REAL		Longitude of label              *
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* Log:									*
C* A. Hardy/NCEP	 8/02						*
C************************************************************************
	REAL		rlat (*), rlon (*)
C*
	INTEGER		indx (20)
C------------------------------------------------------------------------
	iret  = 0
	npm1 = np - 1
C
C*	Find the centroid of the area.
C
	CALL GG_CTRD ( np, rlat, rlon, clat, clon, ier )
C
C*	Find the topmost point below the centroid.
C
	angmin = 0.
	alat   = clat
	alon   = clon
	ipts   = 0
C
	DO k   = 1, npm1
	    IF ( ( rlat ( k ) * clat ) .ge. 0. ) THEN
		deltay = rlat ( k ) - clat
	      ELSE
		deltay = ABS ( rlat ( k ) ) + ABS ( clat )
		IF ( clat .gt. 0. ) deltay = -deltay
	    END IF
	    IF ( ( rlon ( k ) * clon ) .ge. 0. ) THEN
		deltax = rlon ( k ) - clon
	      ELSE
		deltax = 360. - ( ABS ( rlon ( k ) ) + ABS ( clon ) )
		IF ( clon .lt. 0. ) deltax = -deltax
	    END IF
C
	    angle = atan2 ( deltay, deltax )
	    IF ( angle .gt. angmin ) THEN
		angmin = angle
		alat   = rlat ( k )
		alon   = rlon ( k )
	    END IF
C
C*	    Save the indices of all points below the centroid.
C
	    IF ( angle .gt. 0. ) THEN
		ipts = ipts + 1
		indx ( ipts ) = k
	    END IF
	END DO
C
C*	Check that the latitude of the leftmost point is within
C*      10 minutes of the latitude of the bottommost point.
C*	If it is not, use the bottomost point.
C
	DO i = 1, ipts
	    IF ( ( rlat ( indx ( i ) ) - alat ) .gt. .17 ) THEN
	        alat = rlat ( indx ( i ) )
		alon = rlon ( indx ( i ) )
	    END IF
	END DO
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV,
     &            EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.2)                                    --
*
*  -- Contributed by Zlatko Drmac of the University of Zagreb and     --
*  -- Kresimir Veselic of the Fernuniversitaet Hagen                  --
*  -- November 2008                                                   --
*
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* This routine is also part of SIGMA (version 1.23, October 23. 2008.)
* SIGMA is a library of algorithms for highly accurate algorithms for
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
*     -#- Scalar Arguments -#-
*
      IMPLICIT    NONE
      REAL        EPS, SFMIN, TOL
      INTEGER     INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
      CHARACTER*1 JOBV
*
*     -#- Array Arguments -#-
*
      REAL        A( LDA, * ), D( N ), SVA( N ), V( LDV, * ),
     &            WORK( LWORK )
*     ..
*
*  Purpose
*  ~~~~~~~
*  SGSVJ1 is called from SGESVJ as a pre-processor and that is its main
*  purpose. It applies Jacobi rotations in the same way as SGESVJ does, but
*  it targets only particular pivots and it does not check convergence
*  (stopping criterion). Few tunning parameters (marked by [TP]) are
*  available for the implementer.
*
*  Further details
*  ~~~~~~~~~~~~~~~
*  SGSVJ1 applies few sweeps of Jacobi rotations in the column space of
*  the input M-by-N matrix A. The pivot pairs are taken from the (1,2)
*  off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The
*  block-entries (tiles) of the (1,2) off-diagonal block are marked by the
*  [x]'s in the following scheme:
*
*     | *   *   * [x] [x] [x]|
*     | *   *   * [x] [x] [x]|    Row-cycling in the nblr-by-nblc [x] blocks.
*     | *   *   * [x] [x] [x]|    Row-cyclic pivoting inside each [x] block.
*     |[x] [x] [x] *   *   * |
*     |[x] [x] [x] *   *   * |
*     |[x] [x] [x] *   *   * |
*
*  In terms of the columns of A, the first N1 columns are rotated 'against'
*  the remaining N-N1 columns, trying to increase the angle between the
*  corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is
*  tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter.
*  The number of sweeps is given in NSWEEP and the orthogonality threshold
*  is given in TOL.
*
*  Contributors
*  ~~~~~~~~~~~~
*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
*
*  Arguments
*  ~~~~~~~~~
*
*  JOBV    (input) CHARACTER*1
*          Specifies whether the output from this procedure is used
*          to compute the matrix V:
*          = 'V': the product of the Jacobi rotations is accumulated
*                 by postmulyiplying the N-by-N array V.
*                (See the description of V.)
*          = 'A': the product of the Jacobi rotations is accumulated
*                 by postmulyiplying the MV-by-N array V.
*                (See the descriptions of MV and V.)
*          = 'N': the Jacobi rotations are not accumulated.
*
*  M       (input) INTEGER
*          The number of rows of the input matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the input matrix A.
*          M >= N >= 0.
*
*  N1      (input) INTEGER
*          N1 specifies the 2 x 2 block partition, the first N1 columns are
*          rotated 'against' the remaining N-N1 columns of A.
*
*  A       (input/output) REAL array, dimension (LDA,N)
*          On entry, M-by-N matrix A, such that A*diag(D) represents
*          the input matrix.
*          On exit,
*          A_onexit * D_onexit represents the input matrix A*diag(D)
*          post-multiplied by a sequence of Jacobi rotations, where the
*          rotation threshold and the total number of sweeps are given in
*          TOL and NSWEEP, respectively.
*          (See the descriptions of N1, D, TOL and NSWEEP.)
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  D       (input/workspace/output) REAL array, dimension (N)
*          The array D accumulates the scaling factors from the fast scaled
*          Jacobi rotations.
*          On entry, A*diag(D) represents the input matrix.
*          On exit, A_onexit*diag(D_onexit) represents the input matrix
*          post-multiplied by a sequence of Jacobi rotations, where the
*          rotation threshold and the total number of sweeps are given in
*          TOL and NSWEEP, respectively.
*          (See the descriptions of N1, A, TOL and NSWEEP.)
*
*  SVA     (input/workspace/output) REAL array, dimension (N)
*          On entry, SVA contains the Euclidean norms of the columns of
*          the matrix A*diag(D).
*          On exit, SVA contains the Euclidean norms of the columns of
*          the matrix onexit*diag(D_onexit).
*
*  MV      (input) INTEGER
*          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a
*                           sequence of Jacobi rotations.
*          If JOBV = 'N',   then MV is not referenced.
*
*  V       (input/output) REAL array, dimension (LDV,N)
*          If JOBV .EQ. 'V' then N rows of V are post-multipled by a
*                           sequence of Jacobi rotations.
*          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a
*                           sequence of Jacobi rotations.
*          If JOBV = 'N',   then V is not referenced.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V,  LDV >= 1.
*          If JOBV = 'V', LDV .GE. N.
*          If JOBV = 'A', LDV .GE. MV.
*
*  EPS     (input) INTEGER
*          EPS = SLAMCH('Epsilon')
*
*  SFMIN   (input) INTEGER
*          SFMIN = SLAMCH('Safe Minimum')
*
*  TOL     (input) REAL
*          TOL is the threshold for Jacobi rotations. For a pair
*          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is
*          applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.
*
*  NSWEEP  (input) INTEGER
*          NSWEEP is the number of sweeps of Jacobi rotations to be
*          performed.
*
*  WORK    (workspace) REAL array, dimension LWORK.
*
*  LWORK   (input) INTEGER
*          LWORK is the dimension of WORK. LWORK .GE. M.
*
*  INFO    (output) INTEGER
*          = 0 : successful exit.
*          < 0 : if INFO = -i, then the i-th argument had an illegal value
*
*     -#- Local Parameters -#-
*
      REAL        ZERO,         HALF,         ONE,         TWO
      PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, TWO = 2.0E0 )

*     -#- Local Scalars -#-
*
      REAL      AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, BIGTHETA,
     &          CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,ROOTEPS, ROOTSFMIN,
     &          ROOTTOL, SMALL, SN, T, TEMP1, THETA, THSIGN
      INTEGER   BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, ISWROT, jbc,
     &          jgl, KBL, MVL, NOTROT, nblc, nblr, p, PSKIPPED, q,
     &          ROWSKIP, SWBAND
      LOGICAL   APPLV, ROTOK, RSVEC
*
*     Local Arrays
      REAL      FASTR(5)
*
*     Intrinsic Functions
      INTRINSIC ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT
*
*     External Functions
      REAL             SDOT, SNRM2
      INTEGER          ISAMAX
      LOGICAL          LSAME
      EXTERNAL         ISAMAX, LSAME, SDOT, SNRM2
*
*     External Subroutines
      EXTERNAL  SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP
*
*
      APPLV = LSAME(JOBV,'A')
      RSVEC = LSAME(JOBV,'V')
      IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN
         INFO = -1
      ELSE IF ( M .LT. 0 ) THEN
         INFO = -2
      ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN
         INFO = -3
      ELSE IF ( N1 .LT. 0 ) THEN
         INFO = -4
      ELSE IF ( LDA .LT. M ) THEN
         INFO = -6
      ELSE IF ( MV .LT. 0 ) THEN
         INFO = -9
      ELSE IF ( LDV .LT. M ) THEN
         INFO = -11
      ELSE IF ( TOL .LE. EPS ) THEN
         INFO = -14
      ELSE IF ( NSWEEP .LT. 0 ) THEN
         INFO = -15
      ELSE IF ( LWORK .LT. M ) THEN
         INFO = -17
      ELSE
         INFO = 0
      END IF
*
*     #:(
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'SGSVJ1', -INFO )
         RETURN
      END IF
*
      IF ( RSVEC ) THEN
         MVL = N
      ELSE IF ( APPLV ) THEN
         MVL = MV
      END IF
      RSVEC = RSVEC .OR. APPLV

         ROOTEPS     = SQRT(EPS)
         ROOTSFMIN   = SQRT(SFMIN)
         SMALL       = SFMIN  / EPS
         BIG         = ONE   / SFMIN
         ROOTBIG     = ONE  / ROOTSFMIN
         LARGE       = BIG / SQRT(FLOAT(M*N))
         BIGTHETA    = ONE  / ROOTEPS
         ROOTTOL = SQRT(TOL)
*
*     -#- Initialize the right singular vector matrix -#-
*
*     RSVEC = LSAME( JOBV, 'Y' )
*
      EMPTSW = N1 * ( N - N1 )
      NOTROT     = 0
      FASTR(1)   = ZERO
*
*     -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
*
      KBL = MIN0(8,N)
      NBLR = N1 / KBL
      IF ( ( NBLR * KBL ) .NE. N1 ) NBLR = NBLR + 1

*     .. the tiling is nblr-by-nblc [tiles]

      NBLC = ( N - N1 ) / KBL
      IF ( ( NBLC * KBL ) .NE. ( N - N1 ) ) NBLC = NBLC + 1
      BLSKIP = ( KBL**2 ) + 1
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.

      ROWSKIP = MIN0( 5, KBL )
*[TP] ROWSKIP is a tuning parameter.
      SWBAND = 0
*[TP] SWBAND is a tuning parameter. It is meaningful and effective
*     if SGESVJ is used as a computational routine in the preconditioned
*     Jacobi SVD algorithm SGESVJ.
*
*
*     | *   *   * [x] [x] [x]|
*     | *   *   * [x] [x] [x]|    Row-cycling in the nblr-by-nblc [x] blocks.
*     | *   *   * [x] [x] [x]|    Row-cyclic pivoting inside each [x] block.
*     |[x] [x] [x] *   *   * |
*     |[x] [x] [x] *   *   * |
*     |[x] [x] [x] *   *   * |
*
*
      DO 1993 i = 1, NSWEEP
*     .. go go go ...
*
      MXAAPQ = ZERO
      MXSINJ = ZERO
      ISWROT = 0
*
      NOTROT = 0
      PSKIPPED = 0
*
      DO 2000 ibr = 1, NBLR

      igl = ( ibr - 1 ) * KBL + 1
*
*
*........................................................
* ... go to the off diagonal blocks

      igl = ( ibr - 1 ) * KBL + 1

      DO 2010 jbc = 1, NBLC

         jgl = N1 + ( jbc - 1 ) * KBL + 1

*        doing the block at ( ibr, jbc )

         IJBLSK = 0
         DO 2100 p = igl, MIN0( igl + KBL - 1, N1 )

         AAPP = SVA(p)

         IF ( AAPP .GT. ZERO ) THEN

         PSKIPPED = 0

         DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
*
         AAQQ = SVA(q)

         IF ( AAQQ .GT. ZERO ) THEN
            AAPP0 = AAPP
*
*     -#- M x 2 Jacobi SVD -#-
*
*        -#- Safe Gram matrix computation -#-
*
         IF ( AAQQ .GE. ONE ) THEN
            IF ( AAPP .GE. AAQQ ) THEN
               ROTOK = ( SMALL*AAPP ) .LE. AAQQ
            ELSE
               ROTOK = ( SMALL*AAQQ ) .LE. AAPP
            END IF
            IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
               AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) *
     &                  D(p) * D(q) / AAQQ ) / AAPP
            ELSE
               CALL SCOPY( M, A(1,p), 1, WORK, 1 )
               CALL SLASCL( 'G', 0, 0, AAPP, D(p), M,
     &              1, WORK, LDA, IERR )
               AAPQ = SDOT( M, WORK, 1, A(1,q), 1 ) *
     &                D(q) / AAQQ
            END IF
         ELSE
            IF ( AAPP .GE. AAQQ ) THEN
               ROTOK = AAPP .LE. ( AAQQ / SMALL )
            ELSE
               ROTOK = AAQQ .LE. ( AAPP / SMALL )
            END IF
            IF ( AAPP .GT.  ( SMALL / AAQQ ) ) THEN
               AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) *
     &               D(p) * D(q) / AAQQ ) / AAPP
            ELSE
               CALL SCOPY( M, A(1,q), 1, WORK, 1 )
               CALL SLASCL( 'G', 0, 0, AAQQ, D(q), M, 1,
     &              WORK, LDA, IERR )
               AAPQ = SDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP
            END IF
         END IF

         MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) )

*        TO rotate or NOT to rotate, THAT is the question ...
*
         IF ( ABS( AAPQ ) .GT. TOL ) THEN
            NOTROT   = 0
*           ROTATED  = ROTATED + 1
            PSKIPPED = 0
            ISWROT   = ISWROT  + 1
*
            IF ( ROTOK ) THEN
*
               AQOAP = AAQQ / AAPP
               APOAQ = AAPP / AAQQ
               THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ
               IF ( AAQQ .GT. AAPP0 ) THETA = - THETA

               IF ( ABS( THETA ) .GT. BIGTHETA ) THEN
                  T = HALF / THETA
                  FASTR(3) =  T * D(p) / D(q)
                  FASTR(4) = -T * D(q) / D(p)
                  CALL SROTM( M,   A(1,p), 1, A(1,q), 1, FASTR )
                  IF ( RSVEC )
     &            CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
                  SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
                  AAPP   = AAPP*SQRT( AMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
                  MXSINJ = AMAX1( MXSINJ, ABS(T) )
               ELSE
*
*                 .. choose correct signum for THETA and rotate
*
                  THSIGN = - SIGN(ONE,AAPQ)
                  IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
                  T  = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) )
                  CS = SQRT( ONE / ( ONE + T*T ) )
                  SN = T * CS
                  MXSINJ = AMAX1( MXSINJ, ABS(SN) )
                  SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
                  AAPP   = AAPP*SQRT( ONE - T*AQOAP*AAPQ)

                  APOAQ = D(p) / D(q)
                  AQOAP = D(q) / D(p)
                  IF ( D(p) .GE. ONE ) THEN
*
                     IF ( D(q) .GE.  ONE ) THEN
                        FASTR(3) =   T * APOAQ
                        FASTR(4) = - T * AQOAP
                        D(p)  = D(p) * CS
                        D(q)  = D(q) * CS
                        CALL SROTM( M,   A(1,p),1, A(1,q),1, FASTR )
                        IF ( RSVEC )
     &                  CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
                     ELSE
                        CALL SAXPY( M,    -T*AQOAP, A(1,q),1, A(1,p),1 )
                        CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
                        IF ( RSVEC ) THEN
                        CALL SAXPY( MVL, -T*AQOAP,  V(1,q),1, V(1,p),1 )
                        CALL SAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
                        END IF
                        D(p) = D(p) * CS
                        D(q) = D(q) / CS
                     END IF
                  ELSE
                     IF ( D(q) .GE. ONE ) THEN
                        CALL SAXPY( M,     T*APOAQ, A(1,p),1, A(1,q),1 )
                        CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
                        IF ( RSVEC ) THEN
                        CALL SAXPY(MVL,T*APOAQ,     V(1,p),1, V(1,q),1 )
                        CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
                        END IF
                        D(p) = D(p) / CS
                        D(q) = D(q) * CS
                     ELSE
                        IF ( D(p) .GE. D(q) ) THEN
                           CALL SAXPY( M,-T*AQOAP,   A(1,q),1,A(1,p),1 )
                           CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
                           D(p) = D(p) * CS
                           D(q) = D(q) / CS
                           IF ( RSVEC ) THEN
                           CALL SAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
                           CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
                           END IF
                        ELSE
                           CALL SAXPY(M, T*APOAQ,    A(1,p),1,A(1,q),1)
                           CALL SAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
                           D(p) = D(p) / CS
                           D(q) = D(q) * CS
                          IF ( RSVEC ) THEN
                          CALL SAXPY(MVL, T*APOAQ,    V(1,p),1,V(1,q),1)
                          CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
                          END IF
                        END IF
                     END IF
                  ENDIF
               END IF

            ELSE
               IF ( AAPP .GT. AAQQ ) THEN
                  CALL SCOPY( M, A(1,p), 1, WORK, 1 )
                  CALL SLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR)
                  CALL SLASCL('G',0,0,AAQQ,ONE,M,1,   A(1,q),LDA,IERR)
                  TEMP1 = -AAPQ * D(p) / D(q)
                  CALL SAXPY(M,TEMP1,WORK,1,A(1,q),1)
                  CALL SLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
                  SVA(q) = AAQQ*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
                  MXSINJ = AMAX1( MXSINJ, SFMIN )
               ELSE
                  CALL SCOPY( M, A(1,q), 1, WORK, 1 )
                  CALL SLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR)
                  CALL SLASCL('G',0,0,AAPP,ONE,M,1,   A(1,p),LDA,IERR)
                  TEMP1 = -AAPQ * D(q) / D(p)
                  CALL SAXPY(M,TEMP1,WORK,1,A(1,p),1)
                  CALL SLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
                  SVA(p) = AAPP*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
                  MXSINJ = AMAX1( MXSINJ, SFMIN )
               END IF
            END IF
*           END IF ROTOK THEN ... ELSE
*
*           In the case of cancellation in updating SVA(q)
*           .. recompute SVA(q)
            IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS  ) THEN
               IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
                  SVA(q) = SNRM2( M, A(1,q), 1 ) * D(q)
               ELSE
                  T    = ZERO
                  AAQQ = ZERO
                  CALL SLASSQ( M, A(1,q), 1, T, AAQQ )
                  SVA(q) = T * SQRT(AAQQ) * D(q)
               END IF
            END IF
            IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS  ) THEN
               IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
                  AAPP = SNRM2( M, A(1,p), 1 ) * D(p)
               ELSE
                  T    = ZERO
                  AAPP = ZERO
                  CALL SLASSQ( M, A(1,p), 1, T, AAPP )
                  AAPP = T * SQRT(AAPP) * D(p)
               END IF
               SVA(p) = AAPP
            END IF
*              end of OK rotation
         ELSE
            NOTROT   = NOTROT   + 1
*           SKIPPED  = SKIPPED  + 1
            PSKIPPED = PSKIPPED + 1
            IJBLSK   = IJBLSK   + 1
         END IF
      ELSE
         NOTROT   = NOTROT   + 1
         PSKIPPED = PSKIPPED + 1
         IJBLSK   = IJBLSK   + 1
      END IF

*      IF ( NOTROT .GE. EMPTSW )  GO TO 2011
      IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
         SVA(p) = AAPP
         NOTROT = 0
         GO TO 2011
      END IF
      IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
         AAPP = -AAPP
         NOTROT = 0
         GO TO 2203
      END IF

*
 2200    CONTINUE
*        end of the q-loop
 2203    CONTINUE

         SVA(p) = AAPP
*
      ELSE
         IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
         IF ( AAPP .LT. ZERO ) NOTROT = 0
***      IF ( NOTROT .GE. EMPTSW )  GO TO 2011
      END IF

 2100 CONTINUE
*     end of the p-loop
 2010 CONTINUE
*     end of the jbc-loop
 2011 CONTINUE
*2011 bailed out of the jbc-loop
      DO 2012 p = igl, MIN0( igl + KBL - 1, N )
         SVA(p) = ABS(SVA(p))
 2012 CONTINUE
***   IF ( NOTROT .GE. EMPTSW ) GO TO 1994
 2000 CONTINUE
*2000 :: end of the ibr-loop
*
*     .. update SVA(N)
      IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
         SVA(N) = SNRM2( M, A(1,N), 1 ) * D(N)
      ELSE
         T    = ZERO
         AAPP = ZERO
         CALL SLASSQ( M, A(1,N), 1, T, AAPP )
         SVA(N) = T * SQRT(AAPP) * D(N)
      END IF
*
*     Additional steering devices
*
      IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
     &     ( ISWROT .LE. N ) ) )
     &   SWBAND = i

      IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.FLOAT(N)*TOL).AND.
     &   (FLOAT(N)*MXAAPQ*MXSINJ.LT.TOL))THEN
        GO TO 1994
      END IF

*
      IF ( NOTROT .GE. EMPTSW ) GO TO 1994

 1993 CONTINUE
*     end i=1:NSWEEP loop
* #:) Reaching this point means that the procedure has completed the given
*     number of sweeps.
      INFO = NSWEEP - 1
      GO TO 1995
 1994 CONTINUE
* #:) Reaching this point means that during the i-th sweep all pivots were
*     below the given threshold, causing early exit.

      INFO = 0
* #:) INFO = 0 confirms successful iterations.
 1995 CONTINUE
*
*     Sort the vector D
*
      DO 5991 p = 1, N - 1
         q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1
         IF ( p .NE. q ) THEN
            TEMP1  = SVA(p)
            SVA(p) = SVA(q)
            SVA(q) = TEMP1
            TEMP1   = D(p)
            D(p) = D(q)
            D(q) = TEMP1
            CALL SSWAP( M, A(1,p), 1, A(1,q), 1 )
            IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 )
         END IF
 5991 CONTINUE
*
      RETURN
*     ..
*     .. END OF SGSVJ1
*     ..
      END
*

max_stars_repo_name: IRFM/ALOHA

max_issues_repo_name: IRFM/ALOHA

max_forks_repo_name: IRFM/ALOHA


text:
C Contains a subroutine call with uninitiated arg
      FUNCTION RTNEWT(FUNCD,X1,X2,XACC)
      PARAMETER (JMAX=20)
      RTNEWT=.5*(X1+X2)
      DO 11 J=1,JMAX
        CALL FUNCD(RTNEWT,F,DF)
        DX=F/DF
        RTNEWT=RTNEWT-DX
        IF((X1-RTNEWT)*(RTNEWT-X2) < 0.)PAUSE 'jumped out of brackets'
        IF(ABS(DX) < XACC) RETURN
11    CONTINUE
      PAUSE 'RTNEWT exceeding maximum iterations'
      END

ext: for

max_stars_repo_name: sbwhitecap/clocc-hg

max_issues_repo_name: sbwhitecap/clocc-hg

max_forks_repo_name: sbwhitecap/clocc-hg


text:
program copy_test
    implicit none
    integer, parameter :: v_size = 10
    integer :: i
    real, dimension(v_size) :: vector1 = [ (real(i), i=1, v_size) ], vector2
    real, dimension(2*v_size) :: large_vector

    print '(A20, *(F5.1))', 'original: ', vector1
    vector2 = 0.0
    large_vector = 0.0
    call scopy(size(vector1), vector1, 1, vector2, 1)
    print '(A20, *(F5.1))', 'copy N 1 1: ', vector2

    vector2 = 0.0
    call scopy(size(vector1), vector1, 1, vector2, 2)
    print '(A20, *(F5.1))', 'copy N 1 2: ', vector2

    vector2 = 0.0
    call scopy(size(vector1), vector1, 2, vector2, 1)
    print '(A20, *(F5.1))', 'copy N 2 1`: ', vector2

    vector2 = 0.0
    call scopy(size(vector1), vector1, 2, vector2, 2)
    print '(A20, *(F5.1))', 'copy N 2 2`: ', vector2

    large_vector = 0.0
    call scopy(size(vector1), vector1, 1, large_vector, 2)
    print '(A20, *(F5.1))', 'copy N 1 2`: ', large_vector
    call scopy(size(vector1), 3.0*vector1, 1, large_vector(2), 2)
    print '(A20, *(F5.1))', 'shift copy N 1 2`: ', large_vector

end program copy_test

max_stars_repo_name: caguerra/Fortran-MOOC

max_issues_repo_name: gjbex/CMake-intro

max_forks_repo_name: gjbex/CMake-intro


text:
module myLib

    use iso_c_binding

    implicit none

    integer, parameter :: dp = selected_real_kind(15, 307)

contains

    real(kind=dp)  function binomial(n,k) result(coefficient) &
        bind (C, name="myLib_binomial")

        implicit none

        integer, intent(in) :: n, k
        integer :: numerator, i

        if (k == 0) then
            coefficient = 1
        else
            coefficient = 1.0D0
            do i = 1, k
                numerator = n + 1 -i
                coefficient = coefficient * real(numerator)/real(i)
            end do
        end if

    end function binomial

end module myLib

max_stars_repo_name: wilsonify/googletest-examples

max_issues_repo_name: wilsonify/googletest-examples

max_forks_repo_name: wilsonify/googletest-examples


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

program p
 use ISO_C_BINDING
 use check_mod

  interface
    subroutine get_expected_f( src1, expct, n1, n2, n ) bind(C)
     use ISO_C_BINDING
      real(C_FLOAT), value :: src1
      type(C_PTR), value :: expct
      integer(C_INT), value :: n1
      integer(C_INT), value :: n2
      integer(C_INT), value :: n
    end subroutine

    subroutine get_expected_d( src1, expct, n1, n2, n ) bind(C)
     use ISO_C_BINDING
      real(C_DOUBLE), value :: src1
      type(C_PTR), value :: expct
      integer(C_INT), value :: n1
      integer(C_INT), value :: n2
      integer(C_INT), value :: n
    end subroutine
  end interface

  integer, parameter :: N1=0
  integer, parameter :: N2=4
  integer, parameter :: NBR_ORDERS = N2-N1+1
  integer, parameter :: TST_VALUES=5
  integer, parameter :: TSTS=NBR_ORDERS*TST_VALUES
  real*4, target,  dimension(TST_VALUES) :: r_src1
  real*4, target,  dimension(TSTS) :: r_rslt
  real*4, target,  dimension(TSTS) :: r_expct
  real*8 :: valuer

  real*8, target,  dimension(TST_VALUES) :: d_src1
  real*8, target,  dimension(TSTS) :: d_rslt
  real*8, target,  dimension(TSTS) :: d_expct
  real*8 :: value8
  integer :: order = 3

  valuer = -.2
  valued = -.2_8
  do i =  0,TST_VALUES-1
    r_src1(i+1) = valuer + 2*i
    d_src1(i+1) = valued + 2*i
  enddo

  do i=1, TST_VALUES
    r_rslt(1+(i-1)*NBR_ORDERS:) = bessel_jn(N1,N2, r_src1(i))
    d_rslt(1+(i-1)*NBR_ORDERS:) = bessel_jn(N1,N2, d_src1(i))

    call get_expected_f(r_src1(i), C_LOC(r_expct(1+(i-1)*NBR_ORDERS)), &
                        N1, N2, TSTS/NBR_ORDERS)
    call get_expected_d(d_src1(i), C_LOC(d_expct(1+(i-1)*NBR_ORDERS)), &
                         N1, N2, TSTS/NBR_ORDERS)
  enddo

  call checkr4( r_rslt, r_expct, TSTS, rtoler=0.0000003)
  call checkr8( d_rslt, d_expct, TSTS, rtoler=0.0000003_8)

!   print *, "r_expct:"
!   print *, r_expct
!   print *, "r_rslt:"
!   print *, r_rslt
!
!   print *, "d_expct:"
!   print *, d_expct
!   print *, "d_rslt:"
!   print *, d_rslt
end program

max_stars_repo_name: kammerdienerb/flang

max_issues_repo_name: kammerdienerb/flang

max_forks_repo_name: kammerdienerb/flang


text:
module parff_intermediate_repeat_m
    use parff_parsed_items_m, only: parsed_items_t
    use parff_parsed_value_m, only: parsed_value_t

    implicit none
    private
    public :: intermediate_repeat_t

    type, extends(parsed_value_t) :: intermediate_repeat_t
        type(parsed_items_t) :: parsed_so_far
        integer :: remaining
    end type
end module

max_stars_repo_name: everythingfunctional/parff

max_issues_repo_name: everythingfunctional/parff

max_forks_repo_name: everythingfunctional/parff


          program demo_system_geteuid
          use M_system, only : system_geteuid
          implicit none
             write(*,*)'EFFECTIVE UID=',system_geteuid()
          end program demo_system_geteuid


text:
Matts Lock & Key is a locksmiths locksmith who provides professional lockout and rekeying services onsight, 24 hours a day in the Davis area.  License #LCO 3754.

20070516 07:41:13 nbsp Ive used them once and was very satisfied.  Matt was quick and courteous.  Although he did rotate the deadbolt knob 90 degrees, which was confusing for a few days.  But it was broken and now it works great. Users/EdHenn

20070823 00:25:33 nbsp My roommate got locked out of his room at around midnight, and we happen to live about a block away from where the service truck is parked. He called and he quoted $70, and figured itd be cheaper to break his lock off and replace it. Users/DaveSchukin

20071009 16:29:35 nbsp I ended up loosing my key to my apartment and to the apartment mailbox, so I call him up. He charges $70 just for coming out, $10 for the front door, and $15 to do the mailbox. It seems outrageously pricey. Users/AlexNelson

20080615 15:53:56 nbsp Phone number disconnected and no longer in the Yellow Pages... departed business? Users/EdHenn

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
module m_prem

  implicit none
  integer, parameter :: DP = 8

contains

  !! ------------------------------------------------------------------------------------------ !!
  !> Return the modified PREM 1D velocity structure
  !!
  !! Compared to the original model of the Diewonski and Anderson (1981), the seawater layer is
  !! substituted to a crustal structure:
  !! rho=2.6 g/cm^3, vp=5.8 km/s, vs=3.2 km/s qmu=600, qkappa = 57823
  !!
  !! This routine returns Q_P and Q_S rather than Q_kappa and Q_mu, by converting using
  !! a formula of (9.59) & (9.60) of Dahlen and Tromp (1998)
  !--
  subroutine prem(z, rho, vp, vs, qp, qs)

    real(DP), intent(in)  :: z      ! depth
    real(DP), intent(out) :: rho    ! density [g/cm^3]
    real(DP), intent(out) :: vp     ! P wavespeed [km/s]
    real(DP), intent(out) :: vs     ! S wavespped [km/s]
    real(DP), intent(out) :: qp     ! Qp
    real(DP), intent(out) :: qs     ! Qs
    !--
    real(DP)              :: r, x   ! Radius, Normalized Radius
    real(DP) :: qk, qm ! Q_kappa, Q_mu
    real(DP) :: qki, qmi, qpi, qsi
    !----

    r = 6371.0_DP - z
    x = r / 6371.0_DP

    if( 0.0 <= r ) then

      if      ( r <= 1221.5_DP ) then                          ! Inner Core
        rho = 13.0885_DP              -  8.8381_DP*x*x
        vp  = 11.2622_DP              -  6.3640_DP*x*x
        vs  =  3.6678_DP              -  4.4475_DP*x*x
        qm  = 84.6_DP
        qk  = 1327.7_DP
      else if ( r <= 3480.0_DP ) then                                ! Outer Core
        rho = 12.5815_DP -  1.2638_DP*x -  3.6426_DP*x*x -  5.5281_DP*x*x*x
        vp  = 11.0487_DP -  4.0362_DP*x +  4.8023_DP*x*x - 13.5732_DP*x*x*x
        vs  = 0.0_DP
        qm  = 1d100
        qk  = 57823_DP
      else if ( r <= 3630.0_DP ) then                            ! Lower Mantle 1
        rho =  7.9565_DP -  6.4761_DP*x +  5.5283_DP*x*x -  3.0807_DP*x*x*x
        vp  = 15.3891_DP -  5.3181_DP*x +  5.5242_DP*x*x -  2.5514_DP*x*x*x
        vs  =  6.9254_DP +  1.4672_DP*x -  2.0834_DP*x*x +  0.9783_DP*x*x*x
        qm  = 312_DP
        qk  = 57823_DP
      else if ( r <= 5600.0_DP ) then                            ! Lower Mantle 2
        rho =  7.9565_DP -  6.4761_DP*x +  5.5283_DP*x*x -  3.0807_DP*x*x*x
        vp  = 24.9520_DP - 40.4673_DP*x + 51.4832_DP*x*x - 26.6419_DP*x*x*x
        vs  = 11.1671_DP - 13.7818_DP*x + 17.4575_DP*x*x -  9.2777_DP*x*x*x
        qm  = 312_DP
        qk  = 57823_DP
      else if ( r <= 5701.0_DP ) then                            ! Lower Mantle 3
        rho =  7.9565_DP -  6.4761_DP*x +  5.5283_DP*x*x -  3.0807_DP*x*x*x
        vp  = 29.2766_DP - 23.6027_DP*x +  5.5242_DP*x*x -  2.5514_DP*x*x*x
        vs  = 22.3459_DP - 17.2473_DP*x -  2.0834_DP*x*x +  0.9783_DP*x*x*x
        qm  = 312_DP
        qk  = 57823_DP
      else if ( r <= 5771.0_DP ) then                         ! Transition zone 1
        rho =  5.3197_DP -  1.4836_DP*x
        vp  = 19.0957_DP -  9.8672_DP*x
        vs  =  9.9839_DP -  4.9324_DP*x
        qm  = 143_DP
        qk  = 57823_DP
      else if ( r <= 5971.0_DP ) then                         ! Transition zone 2
        rho = 11.2494_DP -  8.0298_DP*x
        vp  = 39.7027_DP - 32.6166_DP*x
        vs  = 22.3512_DP - 18.5856_DP*x
        qm  = 143_DP
        qk  = 57823_DP
      else if ( r <= 6151.0_DP ) then                         ! Transition zone 3
        rho =  7.1089_DP -  3.8045_DP*x
        vp  = 20.3926_DP - 12.2569_DP*x
        vs  =  8.9496_DP -  4.4597_DP*x
        qm  = 143_DP
        qk  = 57823_DP
      else if ( r <= 6346.6_DP ) then                                       ! LVZ
        rho =  2.6910_DP +  0.6924_DP*x
        vp  =  4.1875_DP +  3.9382_DP*x
        vs  =  2.1519_DP +  2.3481_DP*x
        qm  = 80_DP
        qk  = 57823_DP
      else if ( r <= 6346.6_DP ) then                                       ! LID
        rho =  2.6910_DP +  0.6924_DP*x
        vp  =  4.1875_DP +  3.9382_DP*x
        vs  =  2.1519_DP +  2.3481_DP*x
        qm  =  600_DP
        qk  =  57823_DP
      else if ( r <= 6356.0_DP ) then                                   ! Crust 1
        rho =  2.900_DP
        vp  =  6.800_DP
        vs  =  3.900_DP
        qm  =  600_DP
        qk  =  57823_DP
      else if ( r <= 6368.0_DP ) then                                   ! Crust 2
        rho =  2.600_DP
        vp  =  5.800_DP
        vs  =  3.200_DP
        qm  =  600_DP
        qk  =  57823_DP
      else if ( r <= 6371.0_DP ) then                                   ! Crust 3
        rho =  2.600_DP
        vp  =  5.800_DP
        vs  =  3.200_DP
        qm  =  600_DP
        qk  =  57823_DP
      end if

    else
      rho = 0.0_DP
      vp  = 0.0_DP
      vs  = 0.0_DP                            ! for illegal value
      qm  = 0.0_DP
      qk  = 0.0_DP
    end if

    ! atetnuation
    qmi = 1._dp / qm
    qki = 1._dp / qm
    qpi = ( 1.0_dp - (4.0_dp/3.0_dp)*vs*vs/vp/vp ) * qki &
        + 4.0_dp/3.0_dp * vs*vs/vp/vp * qmi
    qsi = qmi
    qp = 1.0_dp / qpi
    qs = 1.0_dp / qsi

  end subroutine prem

end module m_prem

max_stars_repo_name: tktmyd/OpenSWPC

max_issues_repo_name: tktmyd/OpenSWPC

max_forks_repo_name: tktmyd/OpenSWPC


     subroutine Reader(lpr)
!    ...................
!    READ THE INPUT PARAMETERS
!    eta1     -> eta
!    Nitermax - > itermax
!    ...................

       USE VAPHFB_Par
       implicit none
       logical lpr
       character*10 ctemp,b(0:50)
       character*30 ctemp30
       integer itemp,ii,it,isum

       if(lpr) then
       print *, ' ======================== '
       print *, ' Features of Calculations '
       print *, ' ======================== '
       endif

        open(lin,file='hfb.dat',status='old')
        read(lin,'(A10,i1)')    b(0),Input%NPMix
        read(lin,'(A10,i1)')    ctemp,Input%IPMix
        read(lin,'(A10,i1)')    ctemp,Input%KMix
        read(lin,'(A10,i1)')    ctemp,Input%IsHFB
        read(lin,'(A10,i1)')    b(1),Input%IntType
        do it=0,1
           if(Input%IsHFB.eq.0) HFB%ide(it) = 0
           if(Input%IsHFB.eq.1) HFB%ide(it) = 1
        enddo !it

        if(lpr) then
        if(Input%IsHFB.eq.0) then
           print *, ' -> Hartree-Fock Calculation'
        else
           print *, ' -> Hartree-Fock-Bogoliubov Calculation '
        endif

        if(Input%NPMix.eq.0) then
           print *, ' -> No n-p mixing! '
        else
           print *, ' -> Allow for n-p mixing ^_^ '
        endif
        if(Input%IPMix.eq.0) then
           print *, ' -> No parity mixing! '
        else
           print *, ' -> Allow for parity mixing ^_^ '
        endif

        if(Input%KMix.eq.0) then
           print *, ' -> No K mixing/Triaxiality! '
        else
           print *, ' -> Allow for K-mixing/Triaxiality ^_^ '
        endif
        if(Input%IntType.eq.0) then
           print *,' -> Shell-Model Interaction in Limited Model Space!'
        else
           print *,' -> Chiral Interaction in Full Model Space ^_^ '
        endif
        endif
!       ................. shell model int
        if(Input%IntType.eq.0) then
           if(.NOT. ALLOCATED(Input%cIntID)) ALLOCATE(character(len=20) :: Input%cIntID)
           read(lin,'(A10,a18)')  b(2),Input%cIntID
           if(lpr) write(*,'(a,a18)') '     Interaction Type: ',Input%cIntID

           if(.NOT. ALLOCATED(Input%cValID)) ALLOCATE(character(len=6) :: Input%cValID)
           read(lin,'(A10,a5)')   b(3),Input%cValID

!        ..........................
           if(lpr) write(*,'(a,a5)') '     Model Space: ',trim(Input%cValID)
         endif
!       ................. chiral interation
         if(Input%IntType.eq.1) then
           read(lin,'(A10,i1)')    ctemp,Input%InME3B
           if(.NOT. ALLOCATED(Input%cIntID)) ALLOCATE(character(len=20) :: Input%cIntID)
           if(.NOT. ALLOCATED(Input%cValID)) ALLOCATE(character(len=6)  :: Input%cValID)
           read(lin,'(A10,a20)')  b(2),Input%cIntID
           read(lin,'(A10,a6)')   b(3),Input%cValID
           read(lin,'(A10,i2)')  ctemp,Input%ihwHO
           read(lin,'(A10,i2)')  ctemp,Input%iCOM
           write(Input%chwHO,'(a4,i2)') 'hwHO',Input%ihwHO
           if(lpr) then
           write(*,'(a,a20)') '     Interaction Type: ',Input%cIntID
           write(*,'(a,a6)') '     Model Space: ',Input%cValID
           write(*,'(a,a6)') '     Frequency of HO: ',Input%chwHO
           endif
           if(Input%iCOM.eq.1) then
             if(.NOT. ALLOCATED(Input%ctpp)) ALLOCATE(character(len=7) :: Input%ctpp)
             Input%ctpp='_notpp_'
             if(lpr) write(*,'(a)') '     Center-Of-Mass Correction: 1B'
           elseif(Input%iCOM.eq.2) then
             if(.NOT. ALLOCATED(Input%ctpp)) ALLOCATE(character(len=5) :: Input%ctpp)
             Input%ctpp='_tpp_'
             if(lpr) write(*,'(a)') '     Center-Of-Mass Correction: 1B+2B'
           else
             if(lpr) write(*,*) '  Error: Center-of-Mass Correction is not set properly'
           endif
         endif

         if(Input%IntType.eq. 1 .and. Input%cIntID == 'GCN') stop ' Interation Type is Wrong !'
         if(Input%IntType.eq. 1 .and. Input%cIntID == 'KB3') stop ' Interation Type is Wrong !'
         if(Input%IntType.eq. 1 .and. Input%cIntID == 'USD') stop ' Interation Type is Wrong !'

         if(.NOT. ALLOCATED(Input%cFlow)) ALLOCATE(character(len=4) :: Input%cFlow)
         read(lin,'(A10,a4)')   b(4),Input%cFlow

        read(lin,'(A10,I5)')    b(5),Input%IntJT
        read(lin,'(A10,I5)')    b(6),Input%IntIMSRG
        read(lin,'(A10,I5)')    b(7),Input%IsoSpin
        read(lin,'(A10,I6)')    b(8),Input%nprot
        read(lin,'(A10,I6)')    b(9),Input%nneut
        read(lin,'(A10,I5)')    b(10),Input%itermax
        print *, ' Max. iteration:',Input%itermax
        !read(lin,'(A10,F20.6)') b(11),Input%eta
        read(lin,'(A10,a5)')    ctemp,Opt%method   ! optimize method
        read(lin,'(A10,F20.6)') b(11),Opt%lr       ! learning rate or step size
       ! read(lin,'(A10,F20.6)')   b(11),Input%alpha
        read(lin,'(A10,F20.6)') b(12),Input%tolcons
        read(lin,'(A10,F20.6)') b(13),Input%tolgrad
        read(lin,'(A10,I5)')    b(14),Input%inwf
        read(lin,'(A10,I5)')    b(15),PNP%NFOM
        if(PNP%NFOM .le. 1)   PNP%NFOM = 1

!    ............ printout
      if(lpr) then
        if(Input%IntJT.eq.2)   print *,' -> Transform V2B from J-scheme to JTMT scheme '
        if(Input%IntJT.eq.1)   print *,' -> Decouple V2B from JTMT to m-scheme '
        if(Input%IntJT.eq.1)   print *,' -> Read V2B from  m-scheme '
        if(Input%IsoSpin.eq.0) print *,'    Allow the V2B breaking isospin symmetry '
        if(Input%IsoSpin.eq.1) print *,'    The V2B has isospin symmetry '

        print *,' -> Information about the Nucleus: '
        write(*,'(a,i3)') '     Proton: ',Input%nprot
        write(*,'(a,i3)') '     Neutron:',Input%nneut

        print *,' -> Information about the Iteration: '
        write(*,'(a,i3)')   '     Max. Iteration:',Input%itermax
        write(*,'(a,f8.5)') '     Step Size of Gradient Method:',Input%eta
        write(*,'(a,f8.5)') '     Required precision:',Input%tolgrad
        if(PNP%NFOM.gt.1) print *,' -> PNP-VAPHFB method '
        if(PNP%NFOM.le.1) print *,' -> HFB method '
      endif
!   ............. for constraint calculation
        read(lin,*)
        read(lin,'(A10,f8.5)') ctemp,Input%bkick
        read(lin,'(A10,I5)')   b(16),Const%iQB
        read(lin,'(A10,I5)')   b(17),Const%NCONS

        print *,' -> Number of Constraints: ',Const%NCONS

        isum=0
        if(lpr) write(6,*) '.......................'
        if(lpr) print *,' -> Constraint Parameters '
        do ii=3,NCONSMAX  ! 17
            read(lin,'(A10,I1,F20.6)') &
     &           b(15+ii),Icons_y_n(ii),ACONS_MV_aux(ii)
            if(Icons_y_n(ii).eq.1) then
              if(lpr) write(*,'(a,a10,a,f10.5)') '     ', b(15+ii),' =>',ACONS_MV_aux(ii)
            endif
             isum = isum + Icons_y_n(ii)
        end do

        if(lpr) write(6,*) '.......................'
        if(isum.ne.Const%NCONS) then
           write(6,*) 'The sum of constraints does not correspond &
           & with NCONS, fix it in the input file'
           stop
        end if

        ACONS_MV(1)= Input%nprot
        ACONS_MV(2)= Input%nneut
!       ........ plus contraints on N and Z
        Const%NCONS=COnst%NCONS+2 !adding proton/neutron constraint

!   ................
        return
       end


text:
The City of Davis Community Development Department will be hosting a http://www.ci.davis.ca.us/story/?storySimmons_Estate_Visioning_Workshops visioning process for the Sunrise Farm Simmons Estate, an undeveloped 12acre site on 8th Street East Eight Street, adjacent to the Davis Cemetery.

This includes three evening workshops on September 17th, 18th and 20th at the Fred T. Korematsu Elementary School, and an open design studio in the community room of the Walnut Terrace Apartments at 3101 5th Street.

Your participation will ensure that a broad crosssection of the community is involved in the planning process, which is crucial for the creation of a shared vision for development of the site.

20070904 20:40:44 nbsp Did the City buy the property? Users/JasonAller

20070904 21:41:12 nbsp I dont believe the ownership has left the family... although the http://www.ci.davis.ca.us/story/pdfs/Simmons_Estate_Flyer_3.pdf announcement flyer doesnt make that clear. Any change from the current agricultural use and zoning would take planning approvals. It isnt plausible that the owners could get those approvals without something close to accord  so the Planning Department decided (or was directed?) to be proactive. I have also been told by a former Sunrise Farm resident that a change would require a Measure J vote, though the land is already within City limits. Users/DougWalter

20070904 21:47:38 nbsp So if someone were to buy the place and build a single family residence on it and use the rest for some manner of agricultural use there wouldnt be any need for input from the community? Users/JasonAller

20080430 01:06:28 nbsp To answer your question, Jason, the city gets to approve or deny any development plan for the property, whether its one singlefamily residence or a 120unit multifamily development. Whether they own it doesnt matter. The city has to accept public comment, but I think its pretty much up to them what that means. In Davis it usually means having lots of public meetings and discussions.

And to address Dougs comment, a Measure J vote is not required because the property is not designated as agricultural land on the citys land use map. In fact, it is zoned as residential highdensity. Heres a link to the map if youre interested http://www.ci.davis.ca.us/gis/landuseatlas/ . Users/JeremyOgul


text:
C    @(#)glblim.f	20.3 2/13/96
        subroutine glblim
C               To be replaced later
        print 10
  10    format('0 ** ENTERED DUMMY SUBROUTINE "GLBLIM" - IGNORED')
        return
        end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
      program aa07

C     The vector expression is not prettyprinted because PIPS does not manage to
C     parallelize such a loop. Strict monotonicity of power over positive number
C     is not taken into account.

      real x(10), y(10), z(10), u(10,10)

      do i = 1, 3
         x(i**2+1) = 0.
      enddo

      end


text:
module boxlib_module

  use bl_space_module
  use box_module
  use boxarray_module
  use geometry_module
  use multifab_module
  use omp_module
  use parallel_module
  use parmparse_module
  use string_module

end module boxlib_module

max_forks_repo_name: BoxLib-Codes/BoxLib


text:
PROGRAM test_sendrecv

  use iso_c_binding
  use ghex_future_mod
  use ghex_message_mod
  use ghex_comm_mod

  implicit none

  include 'mpif.h'

  integer(c_size_t), parameter :: buffer_size = 1024

  integer :: mpi_rank, mpi_size, mpi_mode, mpi_err

  type(ghex_shared_message) :: msg
  type(ghex_communicator) :: comm
  type(ghex_future) :: future

  integer(1), pointer, dimension(:) :: buffer
  integer :: use_count, i
  procedure(f_callback), pointer :: pcb

  ! init the MPI stuff
  call mpi_init_thread (MPI_THREAD_MULTIPLE, mpi_mode, mpi_err)
  call mpi_comm_size (mpi_comm_world, mpi_size, mpi_err)
  call mpi_comm_rank (mpi_comm_world, mpi_rank, mpi_err)
  print *, "rank ", mpi_rank, "/", mpi_size

  ! create a communicator object
  comm = comm_new();

  ! create a message
  msg = shared_message_new(buffer_size, ALLOCATOR_PERSISTENT_STD)

  ! get the data pointer
  buffer => shared_message_data(msg)

  ! fill in the sender data, initialize the receiver memory
  if (mpi_rank == 0) then
    buffer(:) = int([(i, i=1,buffer_size)], kind=1)
  else
    buffer(:) = 0
  end if

  ! define the size of the message
  call shared_message_resize(msg, buffer_size)

  ! send/recv the message
  if (mpi_rank == 0) then

    ! submitt send requests
    i = 1
    do while (i <= mpi_size-1)
      future = comm_send(comm, msg, i, 1);
      call future_wait(future)
      i = i + 1
    end do
  else

    ! submit recv requests
    future = comm_recv(comm, msg, 0, 1);
    call future_wait(future)
  end if

  ! check the use count (should be 2 on receivers and mpi_size on sender)
  use_count = shared_message_use_count(msg)
  print *, "message use_count after comm == ", use_count

  call shared_message_delete(msg)

  ! cleanup
  call comm_delete(comm)

  ! finalize
  call mpi_barrier (mpi_comm_world, mpi_err)
  call mpi_finalize (mpi_err)

contains

END PROGRAM test_sendrecv

max_stars_repo_name: tehrengruber/GHEX

max_issues_repo_name: tehrengruber/GHEX

max_forks_repo_name: tehrengruber/GHEX


!*****************************************************************************************
!>
!  Drag model

    module drag_module

    use kind_module

    implicit none

    private

    public :: drag_acceleration

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!  Acceleration due to atmospheric drag.

    pure subroutine drag_acceleration(vrel,cd,area,m,rho,acc)

    implicit none

    real(wp),dimension(3),intent(in)  :: vrel   !! velocity relative to the atmosphere [km/s]
    real(wp),intent(in)               :: cd     !! spacecraft drag coefficient [--]
    real(wp),intent(in)               :: area   !! cross-section area [km^2]
    real(wp),intent(in)               :: m      !! spacecraft mass [kg]
    real(wp),intent(in)               :: rho    !! atmospheric density [kg/km^3]
    real(wp),dimension(3),intent(out) :: acc    !! drag acceleration vector [km/s^2]

    real(wp) :: vrel_mag  !! magnitude of the relative velocity [km/s]

    vrel_mag = norm2(vrel)

    acc = - (0.5_wp * rho * cd * area * vrel_mag / m) * vrel

    end subroutine drag_acceleration
!*****************************************************************************************

!*****************************************************************************************
    end module drag_module
!*****************************************************************************************


text:
      SUBROUTINE MT1(N,P,W,C,Z,X,JDIM,JCK,XX,MIN,PSIGN,WSIGN,ZSIGN)
C
C THIS SUBROUTINE SOLVES THE 0-1 SINGLE KNAPSACK PROBLEM
C
C MAXIMIZE  Z = P(1)*X(1) + ... + P(N)*X(N)
C
C SUBJECT TO:   W(1)*X(1) + ... + W(N)*X(N) .LE. C ,
C               X(J) = 0 OR 1  FOR J=1,...,N.
C
C THE PROGRAM IS INCLUDED IN THE VOLUME
C   S. MARTELLO, P. TOTH, "KNAPSACK PROBLEMS: ALGORITHMS
C   AND COMPUTER IMPLEMENTATIONS", JOHN WILEY, 1990
C AND IMPLEMENTS THE BRANCH-AND-BOUND ALGORITHM DESCRIBED IN
C SECTION  2.5.2 .
C THE PROGRAM DERIVES FROM AN EARLIER CODE PRESENTED IN
C  S. MARTELLO, P. TOTH, "ALGORITHM FOR THE SOLUTION OF THE 0-1 SINGLE
C  KNAPSACK PROBLEM", COMPUTING, 1978.
C
C THE INPUT PROBLEM MUST SATISFY THE CONDITIONS
C
C   1) 2 .LE. N .LE. JDIM - 1 ;
C   2) P(J), W(J), C  POSITIVE INTEGERS;
C   3) MAX (W(J)) .LE. C ;
C   4) W(1) + ... + W(N) .GT. C ;
C   5) P(J)/W(J) .GE. P(J+1)/W(J+1) FOR J=1,...,N-1.
C
C MT1 CALLS  1  PROCEDURE: CHMT1.
C
C THE PROGRAM IS COMPLETELY SELF-CONTAINED AND COMMUNICATION TO IT IS
C ACHIEVED SOLELY THROUGH THE PARAMETER LIST OF MT1.
C NO MACHINE-DEPENDENT CONSTANT IS USED.
C THE PROGRAM IS WRITTEN IN 1967 AMERICAN NATIONAL STANDARD FORTRAN
C AND IS ACCEPTED BY THE PFORT VERIFIER (PFORT IS THE PORTABLE
C SUBSET OF ANSI DEFINED BY THE ASSOCIATION FOR COMPUTING MACHINERY).
C THE PROGRAM HAS BEEN TESTED ON A DIGITAL VAX 11/780 AND AN H.P.
C 9000/840.
C
C MT1 NEEDS  8  ARRAYS ( P ,  W ,  X ,  XX ,  MIN ,  PSIGN ,  WSIGN
C                        AND  ZSIGN ) OF LENGTH AT LEAST  N + 1 .
C
C MEANING OF THE INPUT PARAMETERS:
C N    = NUMBER OF ITEMS;
C P(J) = PROFIT OF ITEM  J  (J=1,...,N);
C W(J) = WEIGHT OF ITEM  J  (J=1,...,N);
C C    = CAPACITY OF THE KNAPSACK;
C JDIM = DIMENSION OF THE 8 ARRAYS;
C JCK  = 1 IF CHECK ON THE INPUT DATA IS DESIRED,
C      = 0 OTHERWISE.
C
C MEANING OF THE OUTPUT PARAMETERS:
C Z    = VALUE OF THE OPTIMAL SOLUTION IF  Z .GT. 0 ,
C      = ERROR IN THE INPUT DATA (WHEN JCK=1) IF Z .LT. 0 : CONDI-
C        TION  - Z  IS VIOLATED;
C X(J) = 1 IF ITEM  J  IS IN THE OPTIMAL SOLUTION,
C      = 0 OTHERWISE.
C
C ARRAYS XX, MIN, PSIGN, WSIGN AND ZSIGN ARE DUMMY.
C
C ALL THE PARAMETERS ARE INTEGER. ON RETURN OF MT1 ALL THE INPUT
C PARAMETERS ARE UNCHANGED.
C
      INTEGER P(JDIM),W(JDIM),X(JDIM),C,Z
      INTEGER XX(JDIM),MIN(JDIM),PSIGN(JDIM),WSIGN(JDIM),ZSIGN(JDIM)
      INTEGER CH,CHS,DIFF,PROFIT,R,T
      Z = 0
      IF ( JCK .EQ. 1 ) CALL CHMT1(N,P,W,C,Z,JDIM)
      IF ( Z .LT. 0 ) RETURN
C INITIALIZE.
      CH = C
      IP = 0
      CHS = CH
      DO 10 LL=1,N
        IF ( W(LL) .GT. CHS ) GO TO 20
        IP = IP + P(LL)
        CHS = CHS - W(LL)
   10 CONTINUE
   20 LL = LL - 1
      IF ( CHS .EQ. 0 ) GO TO 50
      P(N+1) = 0
      W(N+1) = CH + 1
      LIM = IP + CHS*P(LL+2)/W(LL+2)
      A = W(LL+1) - CHS
      B = IP + P(LL+1)
      LIM1 = B - A*FLOAT(P(LL))/FLOAT(W(LL))
      IF ( LIM1 .GT. LIM ) LIM = LIM1
      MINK = CH + 1
      MIN(N) = MINK
      DO 30 J=2,N
        KK = N + 2 - J
        IF ( W(KK) .LT. MINK ) MINK = W(KK)
        MIN(KK-1) = MINK
   30 CONTINUE
      DO 40 J=1,N
        XX(J) = 0
   40 CONTINUE
      Z = 0
      PROFIT = 0
      LOLD = N
      II = 1
      GO TO 170
   50 Z = IP
      DO 60 J=1,LL
        X(J) = 1
   60 CONTINUE
      NN = LL + 1
      DO 70 J=NN,N
        X(J) = 0
   70 CONTINUE
      RETURN
C TRY TO INSERT THE II-TH ITEM INTO THE CURRENT SOLUTION.
   80 IF ( W(II) .LE. CH ) GO TO 90
      II1 = II + 1
      IF ( Z .GE. CH*P(II1)/W(II1) + PROFIT ) GO TO 280
      II = II1
      GO TO 80
C BUILD A NEW CURRENT SOLUTION.
   90 IP = PSIGN(II)
      CHS = CH - WSIGN(II)
      IN = ZSIGN(II)
      DO 100 LL=IN,N
        IF ( W(LL) .GT. CHS ) GO TO 160
        IP = IP + P(LL)
        CHS = CHS - W(LL)
  100 CONTINUE
      LL = N
  110 IF ( Z .GE. IP + PROFIT ) GO TO 280
      Z = IP + PROFIT
      NN = II - 1
      DO 120 J=1,NN
        X(J) = XX(J)
  120 CONTINUE
      DO 130 J=II,LL
        X(J) = 1
  130 CONTINUE
      IF ( LL .EQ. N ) GO TO 150
      NN = LL + 1
      DO 140 J=NN,N
        X(J) = 0
  140 CONTINUE
  150 IF ( Z .NE. LIM ) GO TO 280
      RETURN
  160 IU = CHS*P(LL)/W(LL)
      LL = LL - 1
      IF ( IU .EQ. 0 ) GO TO 110
      IF ( Z .GE. PROFIT + IP + IU ) GO TO 280
C SAVE THE CURRENT SOLUTION.
  170 WSIGN(II) = CH - CHS
      PSIGN(II) = IP
      ZSIGN(II) = LL + 1
      XX(II) = 1
      NN = LL - 1
      IF ( NN .LT. II) GO TO 190
      DO 180 J=II,NN
        WSIGN(J+1) = WSIGN(J) - W(J)
        PSIGN(J+1) = PSIGN(J) - P(J)
        ZSIGN(J+1) = LL + 1
        XX(J+1) = 1
  180 CONTINUE
  190 J1 = LL + 1
      DO 200 J=J1,LOLD
        WSIGN(J) = 0
        PSIGN(J) = 0
        ZSIGN(J) = J
  200 CONTINUE
      LOLD = LL
      CH = CHS
      PROFIT = PROFIT + IP
      IF ( LL - (N - 2) ) 240, 220, 210
  210 II = N
      GO TO 250
  220 IF ( CH .LT. W(N) ) GO TO 230
      CH = CH - W(N)
      PROFIT = PROFIT + P(N)
      XX(N) = 1
  230 II = N - 1
      GO TO 250
  240 II = LL + 2
      IF ( CH .GE. MIN(II-1) ) GO TO 80
C SAVE THE CURRENT OPTIMAL SOLUTION.
  250 IF ( Z .GE. PROFIT ) GO TO 270
      Z = PROFIT
      DO 260 J=1,N
        X(J) = XX(J)
  260 CONTINUE
      IF ( Z .EQ. LIM ) RETURN
  270 IF ( XX(N) .EQ. 0 ) GO TO 280
      XX(N) = 0
      CH = CH + W(N)
      PROFIT = PROFIT - P(N)
C BACKTRACK.
  280 NN = II - 1
      IF ( NN .EQ. 0 ) RETURN
      DO 290 J=1,NN
        KK = II - J
        IF ( XX(KK) .EQ. 1 ) GO TO 300
  290 CONTINUE
      RETURN
  300 R = CH
      CH = CH + W(KK)
      PROFIT = PROFIT - P(KK)
      XX(KK) = 0
      IF ( R .LT. MIN(KK) ) GO TO 310
      II = KK + 1
      GO TO 80
  310 NN = KK + 1
      II = KK
C TRY TO SUBSTITUTE THE NN-TH ITEM FOR THE KK-TH.
  320 IF ( Z .GE. PROFIT + CH*P(NN)/W(NN) ) GO TO 280
      DIFF = W(NN) - W(KK)
      IF ( DIFF ) 370, 330, 340
  330 NN = NN + 1
      GO TO 320
  340 IF ( DIFF .GT. R ) GO TO 330
      IF ( Z .GE. PROFIT + P(NN) ) GO TO 330
      Z = PROFIT + P(NN)
      DO 350 J=1,KK
        X(J) = XX(J)
  350 CONTINUE
      JJ = KK + 1
      DO 360 J=JJ,N
        X(J) = 0
  360 CONTINUE
      X(NN) = 1
      IF ( Z .EQ. LIM ) RETURN
      R = R - DIFF
      KK = NN
      NN = NN + 1
      GO TO 320
  370 T = R - DIFF
      IF ( T .LT. MIN(NN) ) GO TO 330
      IF ( Z .GE. PROFIT + P(NN) + T*P(NN+1)/W(NN+1)) GO TO 280
      CH = CH - W(NN)
      PROFIT = PROFIT + P(NN)
      XX(NN) = 1
      II = NN + 1
      WSIGN(NN) = W(NN)
      PSIGN(NN) = P(NN)
      ZSIGN(NN) = II
      N1 = NN + 1
      DO 380 J=N1,LOLD
        WSIGN(J) = 0
        PSIGN(J) = 0
        ZSIGN(J) = J
  380 CONTINUE
      LOLD = NN
      GO TO 80
      END
      SUBROUTINE CHMT1(N,P,W,C,Z,JDIM)
C
C CHECK THE INPUT DATA.
C
      INTEGER P(JDIM),W(JDIM),C,Z
      IF ( N .GE. 2 .AND. N .LE. JDIM - 1 ) GO TO 10
      Z = - 1
      RETURN
   10 IF ( C .GT. 0 ) GO TO 30
   20 Z = - 2
      RETURN
   30 JSW = 0
      RR = FLOAT(P(1))/FLOAT(W(1))
      DO 50 J=1,N
        R = RR
        IF ( P(J) .LE. 0 ) GO TO 20
        IF ( W(J) .LE. 0 ) GO TO 20
        JSW = JSW + W(J)
        IF ( W(J) .LE. C ) GO TO 40
        Z = - 3
        RETURN
   40   RR = FLOAT(P(J))/FLOAT(W(J))
        IF ( RR .LE. R ) GO TO 50
        Z = - 5
        RETURN
   50 CONTINUE
      IF ( JSW .GT. C ) RETURN
      Z = - 4
      RETURN
      END


text:
THIS IS OLD NEWS

Craig Fergus is a UC Davis graduate with a major in WFCB Conservation Biology, has interned with the http://www.swrcb.ca.gov/ California Water Resources Board working on wetland and riparian protection policy, monitored wood ducks duck nest boxes along Putah Creek, helped write species profiles for http://calfish.ucdavis.edu calfish.ucdavis.edu, and this summer will be conducting Northern Goshawk and Spotted owl surveys for the http://www.fs.fed.us Forest Service in http://www.fs.fed.us/r5/eldorado/ El Dorado National Forest.

He also has a show on that fine freeform radio station KDVS called http://kdvs.org/archive/?show726&titleArchive The Deep End, under the pseudonym DJ Haggis.

The http://www.rampantscotland.com/recipes/blrecipe_haggis.htm Haggis name comes from the fact that he is incredibly Scottish even though he was born and raised in the disappointingly boring city of San Jose.

The I Love Davis Davis area is a much more exciting place with a steady stream of music scene live music usually at the Delta of Venus but also in the newly christened Technocultural Studies TCS Building and wiki:sacramento Sacramentos wiki:sacramento:Fools Foundation.

Favorite local acts include: Boss The Big Bit, Antlers, and Sholi

Craig used to swim and play water polo in high school and has been planning to get in the Hickey Pool pool again for 3 years. In the mean time he hopes that his use of Bicycling bicycles as his main form as transport will suffice for exercise.

Craig also thinks the Varsity is pretty rad.

Goals (results)

  Explore The Green Belt (sorta)
  Take pictures of Davis with my new camera and add them to the wiki. (http://www.flickr.com/photos/deependdriver)
  Use the Bike Church more to turn my bruiser into some kind of mutant cruiser (new bike)
  Learn the basics of some foreign languages (I have a nice start on http://cy.wikipedia.org/wiki/Hafan Welsh)
  Become informed on important issues from Shields Library primary sources (still an ignorant American)
  Book a show (see the Villanova House for proof)

20070804 11:18:27 nbsp Hey Craig, if youre looking for stuff to take pictures of, check out Photo Requests. Welcome to the wiki! Users/ArlenAbraham

20070829 20:28:11 nbsp Craig, shouldnt you be coordinating office rather than engaging in hotheaded daviswiki debates? Users/JasonDunne

20070830 07:20:28 nbsp For two reasons: first, because it Wiki Community/General Discussion has been Wiki Social Norms archived before  Wiki Community/Ethics Discussion several times (and those are just the ones off the top of my head). A set of similar topics come up periodically, and the previous times it has come up are never cited the next time it is debated. Im not even sure they should be cited, as the editorship changes, and the current group might come to a different conclusion this particular time. As a result, I dont think even trying to archive them into something that could be pointed at would be a good idea because the eventual community decision is subject to change as the editors change, and you wind up creating dogmatic phrases rather than casual, shifting tradition that takes into account the current editors. Yes, it is a contradictory combo of it doesnt have an effect, and if it has an effect, it locks us into a view that doesnt accept the input of new editors, but thats my reasoning. Its about giving the right to new editors to have a voice in the community not completely negated by editors in the past. Experienced editors already have a strong voice if their reasoning is sound, and tradition carries enough weight to prevent a series of radically contradictory changes that are destructive to the content... theres no need to turn their views (including mine) into dogmatic liturgy. You had a perfect right to question the issue, and the resulting discussion is productive as a venue for all current editors to take stock of the current status, raise their opinions and maybe change their minds a bit. Users/JabberWokky

20071111 16:10:44 nbsp craig. craig.  craig.  Craig.  Craig! Craig!  Craig!  CRAIG!  CRAIIIG! Users/JasonDunne

20100927 22:04:01 nbsp Well, we could make the two of them sidebyside.  But there is no way to guarantee that they will go across the whole window because people will have their browsers open to different widths. Users/CovertProfessor

20110314 17:57:56 nbsp Hi moo! Users/christinevu


text:
C file: example.f		G. Moody	23 August 1995
C                               Last revised:  23 February 2006
C
C -----------------------------------------------------------------------------
C Sample program illustrating use of Fortran wrappers for the WFDB library
C Copyright (C) 1995-2006 George B. Moody
C
C This program is free software; you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by the Free Software
C Foundation; either version 2 of the License, or (at your option) any later
C version.
C
C This program is distributed in the hope that it will be useful, but WITHOUT
C ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
C FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
C details.
C
C You should have received a copy of the GNU General Public License along with
C this program; if not, write to the Free Software Foundation, Inc., 59 Temple
C Place - Suite 330, Boston, MA 02111-1307, USA.
C
C You may contact the author by e-mail (george@mit.edu) or postal mail
C (MIT Room E25-505A, Cambridge, MA 02139 USA).  For updates to this software,
C please visit PhysioNet (http://www.physionet.org/).
C _____________________________________________________________________________
C
C This program is a slightly elaborated version of the C example shown in
C section 1.1 of the WFDB Programmer's Guide.  It uses the WFDB library to open
C record 100s (a sample record, provided in the `data' directory at the same
C level as this one).  The program prints the number of signals, the sampling
C frequency, and the first ten samples from each signal.
C
C To compile this program on a UNIX system, type:
C    f77 example.f wfdbf.c -lwfdb
C To run the resulting executable file, type:
C    a.out
C Compare the output with that shown in section 1.4 of the WFDB Programmer's
C Guide.
C
C If your Fortran compiler is a very old one, you might need to replace the
C tabs at the beginnings of the lines below with spaces.

C The next two lines specify the data types returned by the wrappers.
	implicit integer(a-z)
	real aduphys, getbasecount, getcfreq, sampfreq

	integer i, v(32), g
	real f

C Open up to 32 signals from record 100s.  (There are only 2 signals in this
C record, however.)  Note how we force the string argument to end with an
C explicit NULL (CHAR(0));  this is necessary for any strings passed to C
C functions.
	i = isigopen("100s"//CHAR(0), 32)
	write (6,1) i
 1	format("Number of signals in record 100s = ", i2)

C Check out the sampling frequency of record 100s.  The returned value is
C the sampling frequency in Hz, represented as a C double (Fortran real) value.
	f = sampfreq("100s"//CHAR(0))
	write (6,2) f
 2	format("Sampling frequency = ", f6.2)

C Read the first 10 samples from each signal.  The value returned from getvec
C is the number of signals;  the samples themselves are filled into the v
C array by getvec:  v(1) contains a sample for signal 0, v(2) for signal 1.
	do i = 1, 10
	 g = getvec(v)
	 write (6,3) v(1), v(2)
 3	format("v(1) = ", i4, "    v(2) = ", i4)
	end do
	end

max_stars_repo_name: siddhantshrivastava/ecg-fullDisclosure

max_issues_repo_name: siddhantshrivastava/ecg-fullDisclosure

max_forks_repo_name: siddhantshrivastava/ecg-fullDisclosure


text:
Joanna Villegas is a candidate for ASUCD ASUCD Senate Senate in the Winter 2013 ASUCD Election running on the SMART slate.

Joanna Villegas is 4th year transfer student from San Diego, CA, double majoring in English and Chicana/o Studies. She is currently the Transfer Collective Outreach Coordinator in the Student Recruitment and Retention Center.

 Candidate Statement

Hello beautiful UC Davis community!

My name is Joanna Villegas and I am a transfer student from San Diego, California, double majoring in English and Chicana/o Studies. I am running for ASUCD Senate with Students Matter: Activism, Retention, Teamwork (https://www.facebook.com/UCDSMART). S.M.A.R.T. is a group of sociopolitically conscious students who strive to implement resources and policies that will benefit everyone across their varying identities. I have decided to run for senate because I believe in holistic education and as a Queer Chicana, I want student life on this campus to continuously improve so that all student groups have a voice, feel represented, have the chance to thrive and ultimately graduate from UC Davis with the necessary tools to flourish thereafter.

I am currently involved with Movimiento Estudiantil Chicano de Aztlán (M.E.Ch.A.) to promote higher education within the Chicana/o Latina/o community, the Student Recruitment and Retention Center as the Transfer Collective Outreach Coordinator to promote the transfer process, and the Blue Ribbon Committee for Enhancing the Undergraduate Student Experience to develop resources that ensure student academic success and healthy lifestyles.

As an ASUCD Senator I would like to address the following issues:

ADVOCATE FOR TRANSFER, REENTRY, AND VETERAN STUDENT REPRESENTATION

As a transfer student I have used resources at the Transfer Reentry Veterans Center and Collective in the Student Recruitment and Retention Center. As an outreach coordinator in the SRRC I have also seen excellent resources go unused. I hope to bring visibility to student resources for all students, but specifically Transfer, Reentry, and Veteran Students and enhance their student experience by creating a committee in ASUCD to advocate for Transfer, Reentry, and Veteran students and their needs. This is a priority because transfer students are a largely underrepresented group of students at the university and are least likely to enter spaces like ASUCD because of their shorter length of time at UC Davis.

CREATE OFFICES FOR STUDENT CLUBS AND ORGANIZATIONS

Currently, there are plans to remodel the Memorial Union  one of the most visited buildings on campus  and while these upcoming changes have the potential to revitalize the MU, we must be critical of what this means in regards to enhancing the experience of active organizations and clubs on campus that play a vital role in student retention and academic success. The MU can be a means to increase visibility for clubs and organizations, to promote on campus involvement, and to allow these organizations  that collectively involve thousands of students  to thrive. I will ensure that active clubs and organizations on campus have a space where they can not only meet, but also store items, plan, and work on events and activities.

Vote for informed student leaders that genuinely care about your undergraduate experience and will listen to YOUR needs, VOTE FOR ME JOANNA VILLEGAS #1 for ASUCD Senate, S.M.A.R.T. #25 and F.U.Q. for President and Vice President via https://elections.ucdavis.edu/


text:
!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Complex polylogarithm \f$\operatorname{Li}_5(z)\f$
!> @param z complex argument
!> @return \f$\operatorname{Li}_5(z)\f$
!> @author Alexander Voigt
!*********************************************************************
double complex function cdli5(z)
  implicit none
  double complex :: z, u, u2, u4, u8, c4, lmz, rest, fast_pos_cdlog
  double precision :: rz, iz, nz, pz, lnz, arg
  double precision, parameter :: PI    = 3.1415926535897932D0
  double precision, parameter :: PI2   = 9.8696044010893586D0
  double precision, parameter :: PI4   = 97.409091034002437D0
  double precision, parameter :: zeta5 = 1.0369277551433699D0
  double precision, parameter :: c1    = 1.0823232337111382D0 ! zeta(4)
  double precision, parameter :: c2    = 0.60102845157979714D0 ! zeta(3)/2
  double precision, parameter :: c3    = 0.27415567780803774D0
  double precision, parameter :: c5    = -1D0/240
  double precision, parameter :: bf(19) = (/           &
      1.0D0                 , -15.0D0/32.0D0         , &
      1.3953189300411523D-01, -2.8633777006172840D-02, &
      4.0317412551440329D-03, -3.3985018004115226D-04, &
      4.5445184621617666D-06,  2.3916808048569012D-06, &
     -1.2762692600122747D-07, -3.1628984306505932D-08, &
      3.2848118445335192D-09,  4.7613713995660579D-10, &
     -8.0846898171909830D-11, -7.2387648587737207D-12, &
      1.9439760115173968D-12,  1.0256978405977236D-13, &
     -4.6180551009884830D-14, -1.1535857196470580D-15, &
      1.0903545401333394D-15                           /)
  double precision, parameter :: cs(6) = (/            &
     -1.1574074074074074D-04, 2.0667989417989418D-07,  &
     -1.0935444136502338D-09, 8.6986487449450412D-12,  &
     -8.6899587861588824D-14, 1.0081254080218813D-15   /)

  rz = real(z)
  iz = aimag(z)

   if (iz .eq. 0) then
      if (rz .eq. 0) then
         cdli5 = 0
         return
      endif
      if (rz .eq. 1) then
         cdli5 = zeta5
         return
      endif
      if (rz .eq. -1) then
         cdli5 = -15*zeta5/16
         return
      endif
   endif

   nz  = rz**2 + iz**2
   pz  = datan2(iz, rz)
   lnz = 0.5D0*log(nz)

   if (lnz**2 + pz**2 .lt. 1) then ! |log(z)| < 1
      u = dcmplx(lnz, pz) ! log(z)
      u2 = u**2
      c4 = (25D0/12 - fast_pos_cdlog(-u))/24
      cdli5 =                &
         zeta5 + u * c1 +    &
         u2 * (c2 + u * c3 + &
         u2 * (c4 + u * c5 + &
         u2 * (cs(1) +       &
         u2 * (cs(2) +       &
         u2 * (cs(3) +       &
         u2 * (cs(4) +       &
         u2 * (cs(5) +       &
         u2 * (cs(6)))))))))
      return
   endif

   if (nz .le. 1) then
      u = -fast_pos_cdlog(1 - z)
      rest = 0
   else ! nz > 1
      if (pz .gt. 0) then
         arg = pz - PI
      else
         arg = pz + PI
      endif
      lmz = dcmplx(lnz, arg) ! log(-z)
      u = -fast_pos_cdlog(1 - 1/z)
      rest = -lmz*(7*PI4 + lmz**2*(10*PI2 + 3*lmz**2))/360
   endif

   u2 = u**2
   u4 = u2**2
   u8 = u4**2

   cdli5 =                                                   &
      rest +                                                 &
      u*bf(1) +                                              &
      u2*(bf(2) + u*bf(3)) +                                 &
      u4*(bf(4) + u*bf(5) + u2*(bf(6) + u*bf(7))) +          &
      u8*(bf(8) + u*bf(9) + u2*(bf(10) + u*bf(11)) +         &
          u4*(bf(12) + u*bf(13) + u2*(bf(14) + u*bf(15)))) + &
      u8*u8*(bf(16) + u*bf(17) + u2*(bf(18) + u*bf(19)))

end function cdli5

max_stars_repo_name: Expander/dilogarithm

max_issues_repo_name: Expander/dilogarithm

max_forks_repo_name: Expander/dilogarithm


text:
      subroutine perim (magrx,minrx,magry,minry)
      call gridal (magrx,minrx,magry,minry,0,0,5,1,1)
      return
      end

max_stars_repo_name: ysBach/irafdocgen

max_issues_repo_name: kirxkirx/iraf

max_forks_repo_name: kirxkirx/iraf


!
!     -------------------------------------------------------------
!      S O O 1 2 1 2 P
!     -------------------------------------------------------------
!                                                                  *
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
!     OF ONE PARTICLE OPERATOR IN CASE :           N'1 = N1        *
!                                                                  *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Universite Libre de Bruxelles, Belgium         October 1995  *
!
      SUBROUTINE SOO1212P(IG, KL, IA, IB)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
      USE MEDEFN_C
      USE DIAGNL_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  13:15:20  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE sooa_I
      USE soob_I
      USE two12_I
      USE savenon_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: IG
      INTEGER  :: KL
      INTEGER  :: IA
      INTEGER  :: IB
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: L1, L2, LB, LA, KLM, KLP
      REAL(DOUBLE) :: AP1, A1, C1, C2, G1, GG1, C3, C4, G2, GG2, C55, C66, CC55&
         , CC66, G4, GG4, A2, G3, GG3
!-----------------------------------------------
      L1 = LJ(IA)
      L2 = LJ(IB)
      CALL SOOA (L1, L2, L1, L2, KL, AP1)
      IF (DABS(AP1) < EPS) RETURN
      LB = IJFUL(IB)
      LA = IJFUL(IA)
      KLM = KL - 1
      IF (KLM >= 0) THEN
         CALL SOOB (1, L1, L1, KLM, KL, A1)
         IF (DABS(A1) > EPS) THEN
            CALL TWO12 (KLM, 1, KL, 0, 1, IA, IB, C1)
            CALL TWO12 (KLM, 0, KL, 1, 1, IA, IB, C2)
            G1 = C1 + TWO*C2
            G1 = A1*G1
         ELSE
            G1 = ZERO
         ENDIF
!
         CALL SOOB (1, L2, L2, KLM, KL, A1)
         IF (DABS(A1) > EPS) THEN
            CALL TWO12 (KL, 0, KLM, 1, 1, IA, IB, C1)
            CALL TWO12 (KL, 1, KLM, 0, 1, IA, IB, C2)
            GG1 = C1 + TWO*C2
            GG1 = A1*GG1
         ELSE
            GG1 = ZERO
         ENDIF
      ELSE
         G1 = ZERO
         GG1 = ZERO
      ENDIF
      KLP = KL + 1
      IF (KLP <= IG) THEN
         CALL SOOB (1, L1, L1, KLP, KL, A1)
         IF (DABS(A1) > EPS) THEN
            CALL TWO12 (KLP, 1, KL, 0, 1, IA, IB, C3)
            CALL TWO12 (KLP, 0, KL, 1, 1, IA, IB, C4)
            G2 = C3 + TWO*C4
            G2 = A1*G2
         ELSE
            G2 = ZERO
         ENDIF
!
         CALL SOOB (1, L2, L2, KLP, KL, A1)
         IF (DABS(A1) > EPS) THEN
            CALL TWO12 (KL, 0, KLP, 1, 1, IA, IB, C3)
            CALL TWO12 (KL, 1, KLP, 0, 1, IA, IB, C4)
            GG2 = C3 + TWO*C4
            GG2 = A1*GG2
         ELSE
            GG2 = ZERO
         ENDIF
      ELSE
         G2 = ZERO
         GG2 = ZERO
      ENDIF
      CALL TWO12 (KL, 1, KL, 0, 1, IA, IB, C55)
      CALL TWO12 (KL, 0, KL, 1, 1, IA, IB, C66)
!      CALL TWO12(KL,0,KL,1,1,IA,IB,CC55)
!      CC55=-CC55
!      CALL TWO12(KL,1,KL,0,1,IA,IB,CC66)
!      CC66=-CC66
      CC55 = -C66
      CC66 = -C55
!
!     ( k k )  tenzorine struktura    V  integralas
!
      CALL SOOB (2, L1, L1, KL, KL, A1)
      G4 = C55 + TWO*C66
      G4 = AP1*A1*G4
      IF (DABS(G4) > EPS) CALL SAVENON (7, G4, KL - 1, LA, LB, LA, LB, JA, JB, &
         0)
      CALL SOOB (2, L2, L2, KL, KL, A1)
      GG4 = CC55 + TWO*CC66
      GG4 = AP1*A1*GG4
      IF (DABS(GG4) > EPS) CALL SAVENON (7, GG4, KL - 1, LB, LA, LB, LA, JA, JB&
         , 0)
!
!     ( k  k+1)  ( k k )
!
      CALL SOOB (1, L1, L1, KL, KL, A1)
      CALL SOOB (1, L2, L2, KL, KL, A2)
      G3 = C55 + TWO*C66
      G3 = A1*G3
      GG3 = CC55 + TWO*CC66
      GG3 = A2*GG3
      IF (KL - 1 >= 0) THEN
         A1 = AP1*(G1 + DBLE(KL + 1)*G3)
         IF (DABS(A1) > EPS) CALL SAVENON (6, A1, KL - 2, LB, LA, LB, LA, JA, &
            JB, 0)
         A1 = AP1*(GG1 + DBLE(KL + 1)*GG3)
         IF (DABS(A1) > EPS) CALL SAVENON (6, A1, KL - 2, LA, LB, LA, LB, JA, &
            JB, 0)
      ENDIF
!
!     ( k  k-1)  ( k k )
!
      IF (KLP <= IG) THEN
         A2 = AP1*(G2 - DBLE(KL)*G3)
         IF (DABS(A2) > EPS) CALL SAVENON (6, A2, KL, LA, LB, LA, LB, JA, JB, 0&
            )
         A2 = AP1*(GG2 - DBLE(KL)*GG3)
         IF (DABS(A2) > EPS) CALL SAVENON (6, A2, KL, LB, LA, LB, LA, JA, JB, 0&
            )
      ENDIF
      RETURN
      END SUBROUTINE SOO1212P


text:
!------------------------------------------------------------------!
!      This code is a part of GASS Reweighting codes               !
! Fortran program to calculate the bias potentail applied along    !
!          the metadynamics CV in GASS sumulation                  !
!------------------------------------------------------------------!
!
!
PROGRAM vb_factor
IMPLICIT NONE
REAL*8 :: gridmin1, gridmax1, griddiff1, gridmin2, gridmax2, griddiff2
REAL*8 :: gridmin3, gridmax3, griddiff3, gridmin4, gridmax4, griddiff4
REAL*8 :: T0, T, ktb, bias_fact, alpha_cv, deltaT, den,kbT, kbT0
REAL*8 :: diff_s2, ds2, ss, hh, dum, num, gamma_,alpha
REAL*8, ALLOCATABLE :: cv1(:), cv2(:), ht(:), vbias(:), hill(:)
REAL*8, ALLOCATABLE :: cv3(:), cv4(:), width(:)
INTEGER :: mtd_steps, md_steps, i, t_min, t_max
INTEGER :: mtd_max, w_cv, w_hill, i_mtd, i_md, nbin1
INTEGER :: i_s1, i_s2, i_s3, i_s4, nbin2, nbin3, nbin4

REAL*8, PARAMETER :: kb=1.9872041E-3 !kcal K-1 mol-1
REAL*8, PARAMETER :: kj_to_kcal = 0.239006

open(1,FILE='input',STATUS='old')
OPEN(11,FILE='COLVAR',STATUS='old')
OPEN(12,FILE='HILLS',STATUS='old')
OPEN(21,FILE='data_vbias.dat',STATUS='replace')

CALL get_steps(11,md_steps)
CALL get_steps(12,mtd_steps)

!print *, 'md_steps=', md_steps, 'mtd_steps=', mtd_steps

read(1,*) T,bias_fact
read(1,*) t_min, t_max

IF(t_max.gt.md_steps)STOP '!!ERROR: t_max > total MD steps'

read(1,*) gridmin1, gridmax1, griddiff1
read(1,*) gridmin2, gridmax2, griddiff2
read(1,*) gridmin3, gridmax3, griddiff3
read(1,*) gridmin4, gridmax4, griddiff4
read(1,*) w_cv, w_hill

 deltaT = (bias_fact - 1.d0)*T
 alpha = (T + deltaT)/deltaT

 kbT = kb*T

!write(*,*), 'gamma_=', gamma_

WRITE(*,'(A,I10)')'No: of MTD steps        =',mtd_steps
WRITE(*,'(A,I10)')'No: of MD  steps        =',md_steps
WRITE(*,'(A,F9.2)')'Physical Temp (K)      =',T
WRITE(*,'(A,F9.2)')'CV Temp (K)            =',T
WRITE(*,'(A,F9.2)')'Bias Factor (K)        =',bias_fact
WRITE(*,'(A,F9.2)')'DeltaT      (K)        =',deltaT
WRITE(*,'(A,F9.2)')'Alpha value            =',alpha
WRITE(*,'(A,I10)')'Print Freq. cvmdck_mtd  =',w_cv
WRITE(*,'(A,I10)')'Freq. of Hill Update    =',w_hill
WRITE(*,'(A,I10)')'Reweigtht: Min step     =',t_min
WRITE(*,'(A,I10)')'Reweigtht: Max step     =',t_max

ALLOCATE(cv1(md_steps),cv2(md_steps))
ALLOCATE(cv3(md_steps),cv4(md_steps))
ALLOCATE(vbias(md_steps))
ALLOCATE(ht(mtd_steps))
ALLOCATE(hill(mtd_steps),width(mtd_steps))

DO i_md=1,md_steps
 READ(11,*) dum,cv1(i_md),cv2(i_md),cv3(i_md),cv4(i_md)
     IF( cv1(i_md) .gt.  3.14d0)  cv1(i_md) = cv1(i_md) - 6.28d0
     IF( cv1(i_md) .lt. -3.14d0 ) cv1(i_md) = cv1(i_md) + 6.28d0
     IF( cv2(i_md) .gt.  3.14d0)  cv2(i_md) = cv2(i_md) - 6.28d0
     IF( cv2(i_md) .lt. -3.14d0 ) cv2(i_md) = cv2(i_md) + 6.28d0
     IF( cv3(i_md) .gt.  3.14d0)  cv3(i_md) = cv3(i_md) - 6.28d0
     IF( cv3(i_md) .lt. -3.14d0 ) cv3(i_md) = cv3(i_md) + 6.28d0
     IF( cv4(i_md) .gt.  3.14d0)  cv4(i_md) = cv4(i_md) - 6.28d0
     IF( cv4(i_md) .lt. -3.14d0 ) cv4(i_md) = cv4(i_md) + 6.28d0
END DO

nbin1 = NINT((gridmax1-gridmin1)/griddiff1)+1
nbin2 = NINT((gridmax2-gridmin2)/griddiff2)+1
nbin3 = NINT((gridmax3-gridmin3)/griddiff3)+1
nbin4 = NINT((gridmax4-gridmin4)/griddiff4)+1

write(*,*) nbin1, nbin2, nbin3, nbin4

DO i_mtd=1,mtd_steps
 READ(12,*) dum,hill(i_mtd),width(i_mtd),ht(i_mtd)
      IF( hill(i_mtd) .gt.  3.14d0) hill(i_mtd) = hill(i_mtd) - 6.28d0
      IF( hill(i_mtd) .lt. -3.14d0 )hill(i_mtd) = hill(i_mtd) + 6.28d0
       ht(i_mtd)=ht(i_mtd)*kj_to_kcal
END DO

 write(*,*) 'calculating vbias'

DO i_md=1,md_steps
  mtd_max=(i_md*w_cv/w_hill)
ss=cv2(i_md)
 dum=0.d0
   DO i_mtd=1,mtd_max
    ds2=width(i_mtd)*width(i_mtd)
    hh=ht(i_mtd)/alpha
    diff_s2=ss-hill(i_mtd)
     if (diff_s2 .gt. 3.14d0 ) diff_s2 =diff_s2 - 6.28d0
     if (diff_s2 .lt.-3.14d0 ) diff_s2 =diff_s2 + 6.28d0
    diff_s2=diff_s2*diff_s2*0.5D0
    dum=dum+hh*DEXP(-diff_s2/ds2)
   END DO
vbias(i_md)=dum
write(21,*) i_md, vbias(i_md)
END DO

write(*,*) " vbias written in data_vbias.dat file. "

close(1)
close(11)
close(21)
close(12)

DEALLOCATE(cv2, ht, vbias, hill)
DEALLOCATE(cv3, cv4, width, cv1)

END PROGRAM vb_factor

SUBROUTINE get_steps(iunit,nsteps)
 IMPLICIT NONE
 INTEGER :: iunit, nsteps
 INTEGER :: ios
  nsteps=0
   REWIND(iunit)
     Read_Loop: DO
       READ(iunit,*,IOSTAT=ios)
       IF(ios.ne.0)EXIT Read_Loop
       nsteps=nsteps+1
       END DO Read_Loop
   REWIND(iunit)
END SUBROUTINE
!------------------------------------------------------------------!
!   This code is a part of GASS Reweighting codes                  !
!------------------------------------------------------------------!

max_stars_repo_name: anjibabuIITK/GASS

max_issues_repo_name: anjibabuIITK/GASS

max_forks_repo_name: anjibabuIITK/GASS


text:
      SUBROUTINE E03101 (USEPRM)

C  E03101 tests the handling of error number 101

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

      COMMON /ERRINF/ ERRCOM,FUNCOM,FILCOM, ERNMSW, EXPSIZ,EXPERR,
     1                USRERR, ERRSAV,      FUNSAV,      FILSAV,
     2                EFCNT, EFID
      INTEGER         ERRCOM,FUNCOM,FILCOM, ERNMSW, EXPSIZ,EXPERR(10),
     1                USRERR, ERRSAV(200), FUNSAV(200), FILSAV(200),
     2                EFCNT, EFID(100)
      COMMON /ERRCHR/ CURCON,     ERRSRS,    ERRMRK,    ERFLNM,
     1                CONTAB
      CHARACTER       CURCON*200, ERRSRS*40, ERRMRK*20, ERFLNM*80,
     1                CONTAB(40)*150

C  clipping indicator
      INTEGER     PNCLIP,     PCLIP
      PARAMETER  (PNCLIP=0,   PCLIP=1)
C  relative input priority
      INTEGER     PHIGHR,     PLOWER
      PARAMETER  (PHIGHR=0,   PLOWER=1)

      INTEGER   USEPRM, IDUM1, NUMVDX,ISIZ,IX, V1,V11,V2
      INTEGER   VWSIZ, VDX1(300), VDX2(300)

      REAL      ROTMAT(3,3), MAPMAT(3,3), CPLIMT(4)
      LOGICAL   STREQ, IAREQL

      CURCON = 'the specified representation has not been defined'
      CALL SETVS ('101', EXPERR, EXPSIZ)
      ERRSRS = '2'
      CALL ESETUP (USEPRM)

      CALL POPWK (WKID, CONID, WTYPE)

      CALL PQEVWI (WKID, 0, ERRIND, NUMVDX, IDUM1)
      CALL CHKINQ ('pqevwi', ERRIND)
      IF (NUMVDX .EQ. 0) THEN
         CALL IDMAT (3, ROTMAT)
         CALL IDMAT (3, MAPMAT)
         CALL SETRVS ('0.,1.,0.,1.',CPLIMT,ISIZ)
         CALL PSVWR (WKID,1,ROTMAT,MAPMAT,CPLIMT,PCLIP)
         V1 = 2
         V11 = 3
         V2 = 1
      ELSE
         DO 50 IX = 1, NUMVDX
            CALL PQEVWI (WKID,IX,ERRIND,IDUM1,VDX1(IX))
            CALL CHKINQ ('pqevwi', ERRIND)
50       CONTINUE
         CALL SRTIAR (NUMVDX, VDX1)
         V1 = VDX1(NUMVDX) + 1
         V11 = V1 + 10
         V2 = VDX1(1)
      ENDIF

C  V1 and V11 are undefined; V2 is defined

      CALL RSVTIP (WKID, V1, V11, PLOWER)
      CALL RSVTIP (WKID, V1, V2, PHIGHR)
      CALL RSVTIP (WKID, V2, V1, PLOWER)

      CALL PQEVWI (WKID, 0, ERRIND, VWSIZ, IDUM1)
      CALL CHKINQ ('pqevwi', ERRIND)
      DO 60 IX = 1, VWSIZ
         CALL PQEVWI (WKID, IX, ERRIND, IDUM1, VDX2(IX))
         CALL CHKINQ ('pqevwi', ERRIND)
60    CONTINUE

      CALL TSTIGN (STREQ('OO**') .AND. IAREQL(NUMVDX,VDX1, VWSIZ,VDX2))

      CALL PCLWK (WKID)

      CALL ENDERR

      END


text:
program fixture
   use, intrinsic :: iso_fortran_env, only: wp => real64
   use json_module
   type(json_core) :: json
   type(json_value), pointer :: root
   double precision x(4), y(4)
   call json%initialize()
   call json%create_array(root, '')

   x = (/1, 2, 3, 4/)
   y = (/1, 2, 3, 4/)
   call addcase(root, '0', 4, x, 1, y, -1)

   x = (/1, 2, 3, 4/)
   y = (/1, 2, 3, 4/)
   call addcase(root, '1', 4, x, -1, y, 1)

   x = (/1, 2, 3, 4/)
   y = (/7, 8, 9, 5/)
   call addcase(root, '2', 4, x, 1, y, 1)

   x = (/1, 2, 3, 0/)
   y = (/7, 8, 9, 0/)
   call addcase(root, '3', 3, x, 1, y, 1)

   x = (/1, 2, 0, 0/)
   y = (/7, 8, 0, 0/)
   call addcase(root, '4', 2, x, 1, y, 1)

   x = (/1, 2, 0, 0/)
   y = (/7, 8, 0, 0/)
   call addcase(root, '5', 0, x, 1, y, 1)

   call print(root)
contains
   subroutine addcase(root, ncase, n, x, incx, y, incy)
      type(json_core) :: json
      type(json_value), pointer :: root, case, data
      external dswap
      character(len=*) ncase
      integer n, incx
      double precision x(4), y(4)
      call json%create_object(case, '')
      call json%add(root, case)
      call json%add(case, 'n', n)
      call json%add(case, 'x', x)
      call json%add(case, 'incx', incx)
      call json%add(case, 'y', y)
      call json%add(case, 'incy', incy)
      call dswap(n, x, incx, y, incy)
      call json%create_object(data, 'expect')
      call json%add(data, 'x', x)
      call json%add(data, 'y', y)
      call json%add(case, data)
      nullify (data)
      nullify (case)
   end subroutine addcase

   subroutine print(root)
      use, intrinsic :: iso_fortran_env, only: real64
      use json_module, CK => json_CK
      implicit none

      type(json_core) :: json
      type(json_value), pointer :: root
      logical :: status_ok
      character(kind=CK, len=:), allocatable :: error_msg
      call json%print(root, './tests/fixtures/level1/swap.json')
      if (json%failed()) then
         call json%check_for_errors(status_ok, error_msg)
         write (*, *) 'Error: '//error_msg
         call json%clear_exceptions()
         call json%destroy(root)
      end if
   end subroutine print
end

max_stars_repo_name: Schultzer/libblas

max_issues_repo_name: Schultzer/blas-rs

max_forks_repo_name: Schultzer/blas-rs


text:
      subroutine modisalbe(p1,p2,p3,
     s           brdfalb)
      real p1,p2,p3,brdfalb
      brdfalb=p1+p2*0.189184-p3*1.377622
      return
      end

max_stars_repo_name: xcorail/OTB

max_issues_repo_name: xcorail/OTB

max_forks_repo_name: xcorail/OTB


text:
!-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer r
      integer i

      integer ne
      parameter(ne=3)

      integer*4 ind(2*ne)

      character arg*32

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      do i=1,ne
        ind(2*i-1)=i-1
        ind(2*i  )=i
      enddo

      call ceedelemrestrictioncreate(ceed,ne,2,ne+1,1,ceed_mem_host,&
     & ceed_use_pointer,ind,r,err)

      call ceedelemrestrictionview(r,err)

      call ceedelemrestrictiondestroy(r,err)
      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------

max_stars_repo_name: jrwrigh/libCEED

max_issues_repo_name: jrwrigh/libCEED

max_forks_repo_name: jrwrigh/libCEED


text:
Il vaut mieux que tu prennes un parapluie, parce quil Rain pleut.

20110827 13:25:46 nbsp Hey, thanks for solving that little mystery.  Our home is now listed as a gaming venue on Meetup.com for similar reasons, and Ive been writing RPG books using my home address as my business address, and so I was very curious as to what Frozen Caveman Games was.  Also, its not raining, but thanks for the advice. Users/JabberWokky Evan JabberWokky Edwards, jw.dw@timewarp.org


text:
program q4

use mqc_gaussian

implicit none
character(len=:),allocatable::fileName
type(mqc_gaussian_unformatted_matrix_file)::fileInfo
type(mqc_scf_integral)::density,coreHam,gMatrix,Fock
type(mqc_twoERIs)::twoERIs
type(mqc_molecule_data)::moleculeInfo
type(mqc_scalar)::Vnn,Energy

call mqc_get_command_argument(1,fileName)
call fileInfo%load(fileName)

call fileInfo%getESTObj('scf density',est_integral=density)
call fileInfo%getESTObj('core hamiltonian',est_integral=coreHam)
call fileInfo%getMolData(moleculeInfo)
call fileInfo%get2ERIs('regular',twoERIs)

Vnn = moleculeInfo%getNucRep()
call moleculeInfo%print(6)
call Vnn%print(6,'Nuclear Repulsion Energy (au)')

gMatrix = contraction([twoERIs],density)
Fock = coreHam + gMatrix
Energy = 0.5*contraction(density,coreHam+Fock) + Vnn
call Energy%print(6,'HF Energy (au)')

end program q4

max_stars_repo_name: MQCPack/summerCodingWorkshop

max_issues_repo_name: MQCPack/summerCodingWorkshop

max_forks_repo_name: MQCPack/summerCodingWorkshop