SUBROUTINE CSYSVX_F95(A, B, X, UPLO, AF, IPIV, FACT, &
                      FERR, BERR, RCOND, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: LSAME, ERINFO
   USE F77_LAPACK, ONLY: SYSVX_F77 => LA_SYSVX, ILAENV_F77 => ILAENV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO, FACT
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT(IN) :: A(:,:), B(:,:)
   COMPLEX(WP), INTENT(OUT) :: X(:,:)
   INTEGER, INTENT(INOUT), OPTIONAL, TARGET :: IPIV(:)
   COMPLEX(WP), INTENT(INOUT), OPTIONAL, TARGET :: AF(:,:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!      LA_SYSVX computes the solution to a linear system of equations
! A*X = B, where A is a real or complex symmetric matrix and X and B are
! rectangular matrices or vectors.
!      LA_HESVX computes the solution to a linear system of equations
! A*X = B, where A is a complex Hermitian matrix and X and B are
! rectangular matrices or vectors.
!      LA_SYSVX and LA_HESVX can also optionally estimate the condition
! number of A and compute error bounds.
!
! =========
!
!         SUBROUTINE LA_SYSVX / LA HESVX( A, B, X, UPLO=uplo, AF=af, &
!                        IPIV=ipiv, FACT=fact, FERR=ferr, BERR=berr, &
!                        RCOND=rcond, INFO=info )
!              <type>(<wp>), INTENT(IN) :: A(:,:), <rhs>
!              <type>(<wp>), INTENT(OUT) :: <sol>
!              CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!              <type>(<wp>), INTENT(INOUT), OPTIONAL :: AF(:,:)
!              INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:)
!              CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT
!              REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>, RCOND
!              INTEGER, INTENT(OUT), OPTIONAL :: INFO
!         where
!              <type> ::= REAL | COMPLEX
!              <wp>   ::= KIND(1.0) | KIND(1.0D0)
!              <rhs>  ::= B(:,:) | B(:)
!              <sol>  ::= X(:,:) | X(:)
!              <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! Arguments
! =========
!
! A       (input) REAL or COMPLEX square array, shape (:,:).
!         The symmetric or Hermitian matrix A.
!         If UPLO = 'U', the upper triangular part of A contains the
! 	  upper triangular part of the matrix A, and the strictly lower
! 	  triangular part of A is not referenced. If UPLO = 'L', the
! 	  lower triangular part of A contains the lower triangular part
! 	  of the matrix A, and the strictly upper triangular part of A is
! 	  not referenced.
! B       (input) REAL or COMPLEX array, shape (:,:) with size(B,1) =
!         size(A,1) or shape (:) with size(B) = size(A,1).
!         The matrix B.
! X       (output) REAL or COMPLEX array, shape (:,:) with size(X,1) =
!         size(A,1) and size(X,2) = size(B,2), or shape (:) with size(X)
! 	  = size(A,1).
!         The solution matrix X.
! UPLO    Optional (input) CHARACTER(LEN=1).
!            = 'U': Upper triangle of A is stored;
!            = 'L': Lower triangle of A is stored.
!         Default value: 'U'.
! AF      Optional (input or output) REAL or COMPLEX array, shape (:,:)
!         with the same size as A.
!         If FACT = 'F', then AF is an input argument that contains the
! 	  block diagonal matrix D and the multipliers used to obtain the
! 	  factor L or U from the factorization of A, returned by a
!         previous call to LA_SYSVX or LA_HESVX.
!         If FACT = 'N', then AF is an output argument that contains the
! 	  block diagonal matrix D and the multipliers used to obtain the
! 	  factor L or U from the factorization of A.
! IPIV    Optional (input or output) INTEGER array, shape (:) with
!         size(IPIV) = size(A,1).
!         If FACT = 'F', then IPIV is an input argument that contains
! 	  details of the row and column interchanges and the block
! 	  structure of D.
!         If IPIV(k) > 0 , then rows and columns k and IPIV(k) were
! 	  interchanged and D(k,k) is a 1 by 1 diagonal block.
!         If IPIV(k) < 0 , then there are two cases:
!           1. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
! 	     columns k-1 and -IPIV(k) were interchanged and
! 	     D(k-1:k,k-1:k) is a 2 by 2 diagonal block.
!           2. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, then rows and
! 	     columns k+1 and -IPIV(k) were interchanged and
! 	     D(k:k+1,k:k+1) is a 2 by 2 diagonal block.
!         If FACT = 'N', then IPIV is an output argument that contains
! 	  details of the row and column interchanges and the block
! 	  structure of D; as described above.
! FACT    Optional (input) CHARACTER(LEN=1).
!         Specifies whether the factored form of the matrix A has been
! 	  supplied on entry.
!           = 'N': The matrix A will be copied to AF and factored.
!           = 'F': AF and IPIV contain the factored form of A.
!         Default value: 'N'.
! FERR    Optional (output) REAL array of shape (:), with
!         size(FERR) = size(X,2), or REAL scalar.
!         The estimated forward error bound for each solution vector
! 	  X(j) (the j-th column of the solution matrix X). If XTRUE is
! 	  the true solution corresponding to X(j), FERR(j) is an
!         estimated upper bound for the magnitude of the largest element
! 	  in (X(j)-XTRUE) divided by the magnitude of the largest element
! 	  in X(j). The estimate is as reliable as the estimate for RCOND,
! 	  and is almost always a slight overestimate of the true error.
! BERR    Optional (output) REAL array of shape (:), with size(BERR) =
!         size(X,2), or REAL scalar.
!         The componentwise relative backward error of each solution
! 	  vector X(j) (i.e., the smallest relative change in any element
! 	  of A or B that makes X(j) an exact solution).
! RCOND   Optional (output) REAL
!         The estimate of the reciprocal condition number of A. If RCOND
! 	  is less than the machine
!         precision, the matrix is singular to working precision. This
! 	  condition is indicated by a return code of INFO > 0.
! INFO    (output) INTEGER
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: if INFO = i, and i is
!             <= n: D(i,i) = 0. The factorization has been completed, but
! 	         the block diagonal matrix D is singular, so the
! 		 solution could not be computed.
!             = n+1: D is nonsingular, but RCOND is less than machine
! 	         precision, so the matrix is singular to working
! 		 precision. Nevertheless, the solution and error bounds
! 		 are computed because the computed solution can be more
! 		 accurate than the value of RCOND would suggest.
!             n is the order of A.
!         If INFO is not present and an error occurs, then the program is
! 	  terminated with an error message.
!------------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SYSVX'
   CHARACTER(LEN=6), PARAMETER :: BSNAME = 'CSYTRF'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LFACT, LUPLO
   INTEGER :: LINFO, NRHS, N, NB, LWORK, ISTAT, ISTAT1, SIPIV, S1AF, S2AF, SFERR, SBERR
   REAL(WP) :: LRCOND
!  .. LOCAL POINTERS ..
   INTEGER, POINTER :: LPIV(:)
   REAL(WP),  POINTER :: RWORK(:), LFERR(:), LBERR(:)
   COMPLEX(WP),  POINTER :: WORK(:), LAF(:, :)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, SIZE, MAX
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(A, 1); NRHS = SIZE(B, 2)
   IF( PRESENT(RCOND) ) RCOND = 1.0_WP
   IF( PRESENT(FACT) )THEN; LFACT = FACT; ELSE; LFACT='N'; END IF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = N; END IF
   IF( PRESENT(AF) )THEN; S1AF = SIZE(AF,1); S2AF = SIZE(AF,2)
   ELSE; S1AF = N; S2AF = N; END IF
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
!  .. TEST THE ARGUMENTS
   IF( SIZE(A, 2) /= N .OR. N < 0 )THEN; LINFO = -1
   ELSE IF( SIZE(B, 1) /= N .OR. NRHS < 0 )THEN; LINFO = -2
   ELSE IF( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS )THEN; LINFO = -3
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -4
   ELSE IF( S1AF /= N .OR. S2AF /= N ) THEN; LINFO = -5
   ELSE IF( SIPIV /= N )THEN; LINFO = -6
   ELSE IF( ( .NOT. LSAME(LFACT,'F') .AND. .NOT. LSAME(LFACT,'N') ) .OR. &
     ( LSAME(LFACT,'F') .AND. .NOT.( PRESENT(AF) .AND. PRESENT(IPIV) ) ) )THEN; LINFO = -7
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -8
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -9
   ELSE IF ( N > 0 )THEN
      IF( .NOT.PRESENT(AF) ) THEN; ALLOCATE( LAF(N,N), STAT=ISTAT )
      ELSE; LAF => AF; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(IPIV) )THEN; ALLOCATE( LPIV(N), STAT=ISTAT )
         ELSE; LPIV => IPIV; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(FERR) )THEN; ALLOCATE( LFERR(NRHS), STAT=ISTAT )
         ELSE; LFERR => FERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) )THEN; ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         NB = ILAENV_F77( 1, BSNAME, LUPLO, N, -1, -1, -1 )
         IF( NB <= 1 .OR. NB >= N ) NB = 1; LWORK = MAX(1,2*N,N*NB)
         ALLOCATE(WORK(LWORK), RWORK(N), STAT=ISTAT)
         IF( ISTAT /= 0 )THEN
            DEALLOCATE(WORK, RWORK, STAT=ISTAT1); LWORK = MAX(1,3*N)
            ALLOCATE(WORK(LWORK), RWORK(N), STAT=ISTAT)
            IF( ISTAT /= 0 ) THEN; LINFO = - 100
            ELSE; CALL ERINFO( -200, SRNAME, LINFO ); ENDIF
         ENDIF
      END IF
      IF( ISTAT == 0 )THEN
!        .. CALL LAPACK77 ROUTINE
         CALL SYSVX_F77( LFACT, LUPLO, N, NRHS, A, N, LAF, N, LPIV, B, N, X, N, &
                         LRCOND, LFERR, LBERR, WORK, LWORK, RWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(AF) ) DEALLOCATE( LAF, STAT=ISTAT1 )
      IF( .NOT.PRESENT(IPIV) ) DEALLOCATE( LPIV, STAT=ISTAT1 )
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      IF( PRESENT(RCOND) ) RCOND=LRCOND
      DEALLOCATE( WORK, RWORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE CSYSVX_F95


module mask
implicit none

contains

subroutine mask_interpolation_non_uniform (points,Npts,nxp,nyp,nzp,xp,yp,zp,&
                           mask)
	 implicit none

	 !input
	 integer, intent(in) :: Npts,nxp,nyp, nzp

	 real(8), dimension(nxp), intent(in) :: xp
	 real(8), dimension(nyp), intent(in) :: yp
	 real(8), dimension(nzp), intent(in) :: zp

	 real(8), dimension(Npts,3), intent(in) :: points
	  real(8), dimension(nxp-1, nyp-1, nzp-1), intent(out) :: mask

     !constant
	 real(8) :: dx, dy, dz, x, y, z
	 integer :: indexx1, indexy1, indexz1
	 integer :: ip

     !$OMP PARALLEL DO DEFAULT(SHARED) &
     !$OMP PRIVATE(ip,indexx1, indexy1, indexz1,x, y, z)

	 Do ip=1, Npts
	 	x=points(ip,1)
	    y=points(ip,2)
		z=points(ip,3)

		indexx1=MINLOC(ABS(xp-x),  DIM=1)
		IF (xp(indexx1) < x) THEN
			indexx1=indexx1
		ELSE
		    indexx1=indexx1-1
		END IF

		IF (indexx1 <1) THEN
			indexx1=1
		END IF

		IF (indexx1 >=nxp) THEN
			indexx1=nxp-1
		END IF

		indexy1=MINLOC(ABS(yp-y), DIM=1)
		IF (yp(indexy1) < y) THEN
			indexy1=indexy1
		ELSE
		    indexy1=indexy1-1
		END IF

		IF (indexy1 <1) THEN
			indexy1=1
		END IF

		IF (indexy1 >=nyp) THEN
			indexy1=nyp-1
		END IF

		indexz1=MINLOC(ABS(zp-z), DIM=1)
		IF (zp(indexz1) < z) THEN
			indexz1=indexz1
		ELSE
		    indexz1=indexz1-1
		END IF

		IF (indexz1 <1) THEN
			indexz1=1
		END IF

		IF (indexz1 >=nzp) THEN
			indexz1=nzp-1
		END IF

   mask(indexx1, indexy1, indexz1) = 1

	END DO

	!$OMP END PARALLEL DO

end subroutine mask_interpolation_non_uniform

end module mask


text:
       subroutine reset
C     subroutine    reset      01/09/79
      common /gfatrm/ a(6),b(6),n
      common /gfatrn/ r(6),is
      dimension ai(6)
      data ai/1.,3*0.,1.,0./
      do 1 i=1,6
      a(i)=ai(i)
   1  r(i)=b(i)
      return
	end

ext: f

max_stars_repo_name: sergev/grafor

max_issues_repo_name: sergev/grafor

max_forks_repo_name: sergev/grafor


text:
      SUBROUTINE YSAVE(Y)
*
*
*       Save Y-array in COMMON.
*       -----------------------
*
      INCLUDE 'commonc.h'
      INCLUDE 'common2.h'
      REAL*8 Y(NMX8)
*
*
      NC=N-1
      L=0
      DO I=1,4*NC
      L=L+1
      Q(I)=Y(L)
      END DO
      DO I=1,3
      L=L+1
      CMX(I)=Y(L)
      END DO
      L=L+1
      ENERGY=Y(L)
      DO I=1,4*NC
      L=L+1
      P(I)=Y(L)
      END DO
      DO I=1,3
      L=L+1
      CMV(I)=Y(L)
      END DO
      L=L+1
      CHTIME=Y(L)
*
      RETURN
      END

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse


text:
C
C	$Id: gqegdp.f,v 1.5 2008-07-27 00:20:59 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
      SUBROUTINE GQEGDP(WTYPE,N,ERRIND,NGDP,GDPL)
C
C  INQUIRE LIST element OF AVAILABLE GENERALIZED DRAWING PRIMITIVES.
C
      include 'gkscom.h'
C
      INTEGER WTYPE,N,ERRIND,NGDP,GDPL
C
C  Check if GKS is in the proper state.
C
      CALL GZCKST(8,-1,ERRIND)
      IF (ERRIND .NE. 0) GOTO 100
C
C  Check that the workstation type is valid.
C
      CALL GZCKWK(22,-1,IDUM,WTYPE,ERRIND)
      IF (ERRIND .NE. 0) GO TO 100
C
C  Check if the workstation category is OUTPUT or OUTIN.
C
      CALL GQWKCA(WTYPE,ERRIND,ICAT)
      IF (ICAT.NE.GOUTPT .AND. ICAT.NE.GOUTIN) THEN
        ERRIND = 39
        GO TO 100
      ENDIF
C
C  Check that requested element number is non-negative.
C
      IF (N .LT. 0) THEN
        ERRIND = 2002
        GO TO 100
      ENDIF
C
C  Currently no supported workstation type has any GDPs.
C
      NGDP = 0
      GDPL = 0
      RETURN
C
  100 CONTINUE
      NGDP = -1
      GDPL = -1
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
	SUBROUTINE SNDARR ( delz, nparms, levout, rdata,
     +			    nlevel, hghts, iret )
C************************************************************************
C* SNDARR								*
C*									*
C* This routine will find the average height difference for the 	*
C* sounding. The data will also be interpolated to the new levels.	*
C*									*
C* SNDARR ( DELZ, NPARMS, LEVOUT, RDATA, NLEVEL, HGHTS, IRET )		*
C*									*
C* Input parameters:							*
C*	DELZ		CHAR*		Input requested delta Z		*
C*	NPARMS		INTEGER		Number of parameters		*
C*	LEVOUT		INTEGER		Number of levels of original	*
C*					sounding data			*
C*	RDATA (LLMXLV)	REAL		Original sounding data		*
C*									*
C* Output parameters:							*
C*	NLEVELS		INTEGER		Number of levels of interpolated*
C*					sounding data			*
C*	HGHTS (LLMXLV)	REAL		Interpolated sounding data	*
C*	IRET		INTEGER		Return code			*
C*					 0 = normal			*
C*									*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93	Cleaned up				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	CHARACTER*(*)	delz
	REAL		rdata(*), hghts(*)
C*
	REAL		zdiffs(LLMXLV)
C*
	LOGICAL		respnd
C------------------------------------------------------------------------
	iret = 0
C
	CALL ST_CRNM ( delz, zavg1, ier )
	IF  ( ier .ne. 0 )  zavg1 = 500.
C
	zdiftot = 0
	DO  i = 1, levout-1
	    zdiffs(i) = (rdata((i-1+1)*nparms+IHGHT) -
     +			 rdata((i-1)  *nparms+IHGHT))
	    zdiftot = zdiftot + zdiffs(i)
	END DO
	zavg2 = zdiftot / FLOAT(levout-1)
C
C*	Allow the user a chance to exit.
C
	WRITE  ( 6, 1000 )
1000	FORMAT ( /, 'SNDIAG DELTAZ CALCULATION:', /, /,
     +              ' All height differences:' )
C
	nblk = ( levout - 1 ) / 7 + 1
	i1 = 1
	i2 = 7
	DO  j = 1, nblk
	    IF  ( i2 .gt. (levout-1) ) i2 = levout - 1
	    WRITE ( 6, 1003 ) ( zdiffs(k), k = i1, i2 )
	    i1 = i1 + 7
	    i2 = i2 + 7
	END DO
1003	FORMAT ( '    ', 7F9.2 )
C
	WRITE  ( 6, 1001 ) zavg1
1001	FORMAT ( ' DELZ input    : ', F8.2 )
C
	WRITE  ( 6, 1002 ) zavg2
1002	FORMAT ( ' DELZ computed : ', F8.2 )
C
	CALL IP_RESP ( respnd, ier )
	IF  ( respnd )  THEN
	    CALL TM_ACCP ( ier )
	    IF  ( ier .eq. 2 )  THEN
		iret = -1
	    	RETURN
	    END IF
	END IF
C
C*	Calculate new height levels.
C
	nlevel = 1
	hghts(1) = rdata(0*nparms+IHGHT)
	DO  WHILE ( hghts(nlevel) .lt. rdata((levout-1)*nparms+IHGHT) )
	    nlevel = nlevel + 1
	    hghts(nlevel) = hghts(1) + (nlevel-1)*zavg1
	END DO
	IF  ( hghts(nlevel) .gt. rdata((levout-1)*nparms+IHGHT) )
     +		nlevel = nlevel - 1
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
!==============================================================================!
  subroutine Comm_Mod_Read_Real_Array(fh, arr, disp)
!------------------------------------------------------------------------------!
!   Read real array for sequential runs.                                       !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  integer              :: fh    ! file handle
  real,   dimension(:) :: arr   ! array to read
  integer              :: disp  ! displacement in bytes
!-----------------------------------[Locals]-----------------------------------!
  integer :: length
!==============================================================================!

  length = size(arr)

  ! Position yourself at the right place inside the file
  call fseek(fh, disp, 0)

  ! Read integer
  read(fh) arr(1:length)

  disp = disp + SIZE_REAL * length

  end subroutine

max_issues_repo_name: EdinSmartLab/T-Flows

max_forks_repo_name: EdinSmartLab/T-Flows


text:
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: rfftmb.f,v 1.2 2006-11-21 01:10:19 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DRFFTMB(LOT,JUMP,N,INC,R,LENR,WSAVE,LENSAV,WORK,
     +                   LENWRK,IER)
      INTEGER LOT,JUMP,N,INC,LENR,LENSAV,LENWRK,IER
      DOUBLE PRECISION R(LENR),WSAVE(LENSAV),WORK(LENWRK)
      LOGICAL DXERCON
C
      IER = 0
C
      IF (LENR.LT. (LOT-1)*JUMP+INC* (N-1)+1) THEN
          IER = 1
          CALL DXERFFT('RFFTMB ',6)
      ELSE IF (LENSAV.LT.N+INT(LOG(DBLE(N)))+4) THEN
          IER = 2
          CALL DXERFFT('RFFTMB ',8)
      ELSE IF (LENWRK.LT.LOT*N) THEN
          IER = 3
          CALL DXERFFT('RFFTMB ',10)
      ELSE IF (.NOT.DXERCON(INC,JUMP,N,LOT)) THEN
          IER = 4
          CALL DXERFFT('RFFTMB ',-1)
      END IF
C
      IF (N.EQ.1) RETURN
C
      CALL DMRFTB1(LOT,JUMP,N,INC,R,WORK,WSAVE,WSAVE(N+1))
      RETURN
      END


text:
    MODULE mod_example_readmtx
    CONTAINS
    SUBROUTINE example_readmtx(ipath,n,nz,indx,jndx,rval)
    IMPLICIT NONE
    CHARACTER(256) :: ipath
    INTEGER :: n,nz
    INTEGER, ALLOCATABLE, DIMENSION(:) :: indx,jndx
    DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: rval
!
    CHARACTER(7) :: field
    CHARACTER(10) :: rep
    CHARACTER(19) :: symm
!
    INTEGER :: iunit=999,nz_mx,itmp,ival
    COMPLEX :: cval
!
    ALLOCATABLE :: ival,cval
    DIMENSION :: ival(:),cval(:)
!
    PARAMETER (nz_mx=2147483647)
!
!-----------------------------------------------------------------------
    OPEN(UNIT=iunit,FILE=TRIM(ipath),STATUS='OLD',&
    &   ACCESS='SEQUENTIAL',ACTION='READ')
    CALL mminfo(iunit,rep,field,symm,itmp,n,nz)
!
    ALLOCATE(indx(nz),jndx(nz),rval(nz))
    CALL mmread(iunit,rep,field,symm,n,n,nz,nz_mx,&
    &   indx,jndx,ival,rval,cval)
!
    CLOSE(iunit)
    RETURN
    END SUBROUTINE example_readmtx
    END MODULE mod_example_readmtx
!
!=======================================================================
    SUBROUTINE example_writekval(n,kndx,kval)
    IMPLICIT NONE
    INTEGER :: n
    INTEGER,DIMENSION(n) :: kndx
    DOUBLE PRECISION,DIMENSION(n) :: kval
!
    CHARACTER(256) :: opath
    INTEGER :: ounit=888,i
!
!-----------------------------------------------------------------------
!
    IF(n.EQ.1) THEN
        WRITE(opath,"(A6,I0.8,A4)") './eval',kndx(1),'.txt'
    ELSE
        WRITE(opath,"(A6,I0.8,A2,I0.8,A4)") &
            & './eval',kndx(1),'to', kndx(n),'.txt'
    END IF
!
    OPEN(UNIT=ounit,FILE=TRIM(opath),STATUS='REPLACE',&
    &   ACCESS='SEQUENTIAL',ACTION='WRITE')
!
    DO i=1,n
        WRITE(ounit,"(I8,2X,E28.18)") kndx(i),kval(i)
    END DO
!
    CLOSE(ounit)
    RETURN
    END SUBROUTINE example_writekval
!
!=======================================================================
    SUBROUTINE example_writekvec(m,n,kndx,kvec)
    IMPLICIT NONE
    INTEGER :: m,n
    INTEGER,DIMENSION(n) :: kndx
    DOUBLE PRECISION,DIMENSION(m,n) :: kvec
!
    CHARACTER(256) :: opath
    INTEGER :: ounit=777,i,j
!
!-----------------------------------------------------------------------
!
    DO j=1,n
        WRITE(opath,"(A6,I0.8,A4)") './evec',kndx(j),'.txt'
        OPEN(UNIT=ounit,FILE=TRIM(opath),STATUS='REPLACE',&
            &   ACCESS='SEQUENTIAL',ACTION='WRITE')
!
        DO i=1,m
            WRITE(ounit,"(E28.18)") kvec(i,j)
        END DO
!
        CLOSE(ounit)
    END DO
!
    RETURN
    END SUBROUTINE example_writekvec

max_stars_repo_name: lee-djl/k-ep

max_issues_repo_name: lee-djl/k-ep

max_forks_repo_name: lee-djl/k-ep


text:
	SUBROUTINE SI_GEMP  ( lunf, ihhmm, parms, nparm, drct, dtnm,
     +                        iret )
C************************************************************************
C* SI_GEMP                                                            	*
C*                                                                      *
C* This subroutine writes a decoded SI report to an existing GEMPAK 	*
C* file.								*
C* 								        *
C* SI_GEMP  ( LUNF, IHHMM, CPRMS, PARMS, NPARM, NUMPRM, IMNEM, IRET )   *
C*								        *
C* Input parameters:						        *
C*	LUNF		INTEGER  	Surface file number             *
C*	IHHMM		INTEGER		Verification time (HHMM)        *
C*	PARMS (*)       CHAR*		Parameter list                  *
C*	NPARM		INTEGER		Number of parameters            *
C*	DRCT		REAL		Direction			*
C*	DTNM		REAL		Distance in nautical miles	*
C*								        *
C* Output parameters:						        *
C*	IRET		INTEGER		Return code                     *
C*					  0 = normal return             *
C**								        *
C* Log:							        	*
C* T. Lee/SAIC         8/02						*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
C*
	CHARACTER*(*)	parms (*)
C*
	REAL		rdata (2)
C*
C------------------------------------------------------------------------
	iret = 0
C
C*	Initialize the GEMPAK array first.
C
	DO ii = 1, nparm
	    rdata ( ii ) = RMISSD
	END DO
C
	IF  ( parms ( 1 ) .eq. 'DRCT' )  THEN
	    rdata ( 1 ) = drct
	    rdata ( 2 ) = dtnm
	  ELSE IF ( parms ( 1 ) .eq. 'DTNM' )  THEN
	    rdata ( 1 ) = dtnm
	    rdata ( 2 ) = drct
	  ELSE
	    CALL DC_WLOG ( 2, 'DCIDFT', -3, parms (1), ier )
	END IF
C
C*	Write the data to a surface data file.
C
	CALL SF_WDAT ( lunf, ihhmm, rdata, iret )
	IF ( iret .ne. 0 ) THEN
	    CALL DC_WLOG ( 2, 'SF', iret, ' ', ier )
	END IF
C*
	RETURN
	END


text:
      subroutine elastic_energy(ele, qe)

       use mod_parameters
	  common/custr/   sign1(nelemg),sign2(nelemg),
     > sign3(nelemg),sign4(nelemg)
	  common/wblock12/ Y_modulus(nume),possion_ratio(nume),tau_y(nume)
	  common/range/   mft,mlt,lft,llt,nftm1

	  integer nftm1, ink, ele
	  real E, v, Y_modulus, possion_ratio
	  real epx, epy, epxy, qe

	  qe=0.0
	  ink=ele+nftm1
	  E=Y_modulus(ink)
	  v=possion_ratio(ink)

	  epx=(1+v)/E*((1-v)*sign1(ele)-v*sign2(ele))
	  epy=(1+v)/E*(-v*sign1(ele)+(1-v)*sign2(ele))
	  epxy=(1+v)/E*2*sign4(ele)

	  qe=(sign1(ele)*epx+sign2(ele)*epy+sign4(ele)*epxy)/2.0

	  end

max_stars_repo_name: imohame/LabCode

max_issues_repo_name: imohame/LabCode

max_forks_repo_name: imohame/LabCode


text:
Exit 74 Designs is a fullservice graphic design and web design firm. They offer a wide range of services to fit their clients needs. Their graphic design and user friendly websites are cohesive, creative and will effectively communicate your message.

The business is coowned by Frran Molina and Erin Pace. Together, they have over 20 years of design experience, expressed in their statement, we love what we do, and it shows.

  Need a website?  There are several web design firms in Davis!

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


! { dg-do run }
! Test the extension of intrinsic operators
module m1
 interface operator(*)
  module procedure f1
  module procedure f2
  module procedure f3
 end interface

 interface operator(.or.)
  module procedure g1
 end interface

 interface operator(//)
  module procedure g1
 end interface

contains

 function f1(a,b) result (c)
  integer, dimension(2,2), intent(in) :: a
  integer, dimension(2), intent(in)   :: b
  integer, dimension(2)   :: c
  c = matmul(a,b)
 end function f1
 function f2(a,b) result (c)
  real, dimension(2,2), intent(in) :: a
  real, dimension(2), intent(in)   :: b
  real, dimension(2)   :: c
  c = matmul(a,b)
 end function f2
 function f3(a,b) result (c)
  complex, dimension(2,2), intent(in) :: a
  complex, dimension(2), intent(in)   :: b
  complex, dimension(2)   :: c
  c = matmul(a,b)
 end function f3

 elemental function g1(a,b) result (c)
   integer, intent(in) :: a, b
   integer :: c
   c = a + b
 end function g1

end module m1

  use m1
  implicit none

  integer, dimension(2,2) :: ai
  integer, dimension(2)   :: bi, ci
  real, dimension(2,2) :: ar
  real, dimension(2)   :: br, cr
  complex, dimension(2,2) :: ac
  complex, dimension(2)   :: bc, cc

  ai = reshape((/-2,-4,7,8/),(/2,2/)) ; bi = 3
  if (any((ai*bi) /= matmul(ai,bi))) call abort()
  if (any((ai .or. ai) /= ai+ai)) call abort()
  if (any((ai // ai) /= ai+ai)) call abort()

  ar = reshape((/-2,-4,7,8/),(/2,2/)) ; br = 3
  if (any((ar*br) /= matmul(ar,br))) call abort()

  ac = reshape((/-2,-4,7,8/),(/2,2/)) ; bc = 3
  if (any((ac*bc) /= matmul(ac,bc))) call abort()

end


text:
C    @(#)himva.f	20.3 2/13/96
      real function himva (s,basmva)
C
C     Function to calculate the higher of the two MVA's in or out of a
C       transformer for analysis reporting purposes.
C     S is for complex power.  BASMVA is the system base MVA.
C
      complex s(2)
C
      a1 = cabs(s(1))*basmva
      a2 = cabs(s(2))*basmva
      himva = amax1(a1,1.0e-6)
      himva = amax1(a2,himva)
      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:
Deanna Beals usually goes by the nickname River, or DJ (Thats right folks, two nicknames for the price of one!).

She is originally from Lake Tahoe, California

Now she lives in the Lex!

where she grew up backcountry telemark skiing,

hiking, fishing, and extreme rock crawling. She attended Lake Tahoe Community College, Sierra College, Mendocino College and Feather River College, graduating with an A.S. in Equine Studies with an emphasis in Horse Training, and an A.A. in Liberal Arts in 2008. She is currently attending UC Davis for a B.S. in Animal Science, and hopes to finish her schooling with a Doctorates in Veterinary Medicine, and become a Professor for Animal Behaviour.

Likes:
  working on her car
  snuggling in bed
  sunshine and plants
  spelling things british
  watching horses run

Dislikes:
  people who park across the white lines

Rivers biggest passion is horses. Even though she didnt come from a family that knew nor cared about the beasts, she somehow had it in her blood. She started her horse carreer by adopting a wild 3 year old mustang mare, which she named Namayuna: Its Native American Piaute for lost but found. She chose the name because normally horses are named after thier ancestors, but since this was a mustang, there was no way to know who the horses parents were. So she chose a Piaute name because the Native American ancestors that lived on the land she was captured from was the closest traceable relative she had. Plus they were horse people.

She continued her equine education at Feather River College, where she started and sold several quarter horses. Two colts she started there she competed with the Feather River College team against Cal Poly San Louis Obispo on international television. Her team won both years, and the second year she placed highest score.

The second colt she competed ended up sold for $15,000 at the Snaffle Bit Futurity Select Sale in Reno.

The last horse she sold went to a man who lived in Hawaii. For her first show (let alone in Hawaii!), they won first place in cutting.

Okay enough bragging.

River has one pet, a border collie male named Hoss. He is probably the coolest dog ever. He fishes,

drinks at the bar,

and goes hiking and skiing!

Okay, really now its enough bragging.

Another one of Rivers big passions is working on trucks.

Rock crawlers specifically, and sometimes her modest Honda CRV, otherwise known as Red Rocket.

Latest Riverfox Quote:
    Wow everyone on here is really creative... now I feel like a n00b...

20090728 00:36:08 nbsp Hey, Welcome to the Wiki. I really like skiing and hiking too, Ive just started learning to telemark. I tend to prefer cross country to downhill (more relaxing), but I need more telemark practice at the resorts. Have you been to the Bear Valley Telemark Festival? Is this a good way to learn? Do you ski with skins or waxless skis? Thanks for any tips. Users/NickSchmalenberger

20090728 00:45:54 nbsp Ive never been to the festival, but Ive had lots of friends who have gone. It sounds like fun, but Im not sure about instruction. There seem to be two types of tele skiing; old school and new school. I learned the new school because I trained for PSIA telemark certification. Not saying that the old school way is wrong, but I do believe its less effective with the gear we ski on today...

I ski regular downhill skis (i.e. those without fishscales or attatched skins), and ski them waxed just as any other downhill ski would be, and then use skins when I need to go up!

I might start a telemark skiing club, so keep your earballs peeled! Users/DeannaBeals

20090728 00:58:07 nbsp Cool, I have a pair of K2 Piste Stinx with Superloop bindings. I took them to Squaw once last winter and managed not to fall too much, but I didnt get to telemark very much either, since I had to try to keep up with my friends for most of the time. I did get to practice by myself for an hour or two though with the book __Freeheel Skiing: Telemark and Parallel Techniques__. You might want to join the Davis Back Country Skiers mailing list too. I went to one of their meetings, and a lot of them seemed to be AT skiers and maybe much more hardcore than me, but there was a great slideshow about skiing to the top of Mt. Logan by Peter Green I think.  Users/NickSchmalenberger

20090728 06:35:46 nbsp Cool... another great book (the one that I refer to the most when Im teaching) is Mike and Allens Really Cool Telemark Book. They also make an awesome general mountaineering book too. Users/DeannaBeals