text:
      SUBROUTINE MB02UW( LTRANS, N, M, PAR, A, LDA, B, LDB, SCALE,
     $                   IWARN )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve a system of the form  A X = s B  or  A' X = s B  with
C     possible scaling ("s") and perturbation of A.  (A' means
C     A-transpose.)  A is an N-by-N real matrix, and X and B are
C     N-by-M matrices.  N may be 1 or 2.  The scalar "s" is a scaling
C     factor (.LE. 1), computed by this subroutine, which is so chosen
C     that X can be computed without overflow.  X is further scaled if
C     necessary to assure that norm(A)*norm(X) is less than overflow.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LTRANS  LOGICAL
C             Specifies if A or A-transpose is to be used, as follows:
C             =.TRUE. :  A-transpose will be used;
C             =.FALSE.:  A will be used (not transposed).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  It may (only) be 1 or 2.
C
C     M       (input) INTEGER
C             The number of right hand size vectors.
C
C     PAR     (input) DOUBLE PRECISION array, dimension (3)
C             Machine related parameters:
C             PAR(1) =: PREC  (machine precision)*base, DLAMCH( 'P' );
C             PAR(2) =: SFMIN safe minimum,             DLAMCH( 'S' );
C             PAR(3) =: SMIN  The desired lower bound on the singular
C                             values of A.  This should be a safe
C                             distance away from underflow or overflow,
C                             say, between (underflow/machine precision)
C                             and (machine precision * overflow).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= N.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the matrix B (right-hand side).
C             On exit, the leading N-by-M part of this array contains
C             the N-by-M matrix X (unknowns).
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= N.
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor that B must be multiplied by to insure
C             that overflow does not occur when computing X.  Thus,
C             A X  will be SCALE*B, not B (ignoring perturbations of A).
C             SCALE will be at most 1.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warnings (A did not have to be perturbed);
C             = 1:  A had to be perturbed to make its smallest (or only)
C                   singular value greater than SMIN (see below).
C
C     METHOD
C
C     Gaussian elimination with complete pivoting is used. The matrix A
C     is slightly perturbed if it is (close to being) singular.
C
C     FURTHER COMMENTS
C
C     If both singular values of A are less than SMIN, SMIN*identity
C     will be used instead of A.  If only one singular value is less
C     than SMIN, one element of A will be perturbed enough to make the
C     smallest singular value roughly SMIN.  If both singular values
C     are at least SMIN, A will not be perturbed.  In any case, the
C     perturbation will be at most some small multiple of
C     max( SMIN, EPS*norm(A) ), where EPS is the machine precision
C     (see LAPACK Library routine DLAMCH).  The singular values are
C     computed by infinity-norm approximations, and thus will only be
C     correct to a factor of 2 or so.
C
C     Note: all input quantities are assumed to be smaller than overflow
C     by a reasonable factor.  (See BIGNUM.)  In the interests of speed,
C     this routine does not check the inputs for errors.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 2009.
C     Based on the LAPACK Library routine DLALN2.
C
C     REVISIONS
C
C     V. Sima, Nov. 2010.
C
C     KEYWORDS
C
C     Linear system of equations, matrix operations, matrix algebra.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C
C     .. Scalar Arguments ..
      LOGICAL            LTRANS
      INTEGER            IWARN, LDA, LDB, N, M
      DOUBLE PRECISION   SCALE, SMIN
C
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), PAR( * )
C
C     .. Local Scalars ..
      INTEGER            I, ICMAX, J
      DOUBLE PRECISION   BBND, BIGNUM, BNORM, B1, B2, CMAX, C21, C22,
     $                   CS, EPS, L21, SCALEP, SMINI, SMLNUM, TEMP, U11,
     $                   U11R, U12, U22, XNORM, X1, X2
C
C     .. Local Arrays ..
      LOGICAL            RSWAP( 4 ), ZSWAP( 4 )
      INTEGER            IPIVOT( 4, 4 )
      DOUBLE PRECISION   C( 2, 2 ), CV( 4 )
C
C     ..External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLANGE
      EXTERNAL           DLANGE, IDAMAX
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
C     ..
C     .. Equivalences ..
      EQUIVALENCE        ( C( 1, 1 ), CV( 1 ) )
C     ..
C     .. Data statements ..
      DATA               ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. /
      DATA               RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. /
      DATA               IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4,
     $                   3, 2, 1 /
C
C     .. Executable Statements ..
C
C     For efficiency, the input arguments are not tested.
C
      IWARN = 0
C
C     Compute BIGNUM.
C
      SMIN   = PAR( 3 )
      EPS    = PAR( 1 )
      SMLNUM = TWO*PAR( 2 ) / EPS
      BIGNUM = ONE / SMLNUM
C
C     Standard initializations.
C
      SCALE = ONE
C
      IF( N.EQ.1 ) THEN
C
C        1-by-1  (i.e., scalar) systems  C X = B.
C
         CS    = A( 1, 1 )
         CMAX  = ABS( CS )
         SMINI = MAX( SMIN, SMLNUM, EPS*CMAX )
C
C        If | C | < SMINI, use C = SMINI.
C
         IF( CMAX.LT.SMINI ) THEN
            CS    = SMINI
            CMAX  = SMINI
            IWARN = 1
         END IF
C
C        Check scaling for  X = B / C.
C
         BNORM = ABS( B( 1, IDAMAX( M, B, LDB ) ) )
         IF( CMAX.LT.ONE .AND. BNORM.GT.ONE ) THEN
            IF( BNORM.GT.BIGNUM*CMAX )
     $         SCALE = ONE / BNORM
         END IF
C
C        Compute X.
C
         DO 10 I = 1, M
            B( 1, I ) = ( B( 1, I )*SCALE ) / CS
   10    CONTINUE
C
      ELSE
C
C        2x2 systems.
C
C        Compute C = A  (or  A').
C
         C( 1, 1 ) = A( 1, 1 )
         C( 2, 2 ) = A( 2, 2 )
         IF( LTRANS ) THEN
            C( 1, 2 ) = A( 2, 1 )
            C( 2, 1 ) = A( 1, 2 )
         ELSE
            C( 2, 1 ) = A( 2, 1 )
            C( 1, 2 ) = A( 1, 2 )
         END IF
C
         BNORM = DLANGE( 'M', N, M, B, LDB, CV )
C
C        Find the largest element in C.
C
         CMAX  = ZERO
         ICMAX = 0
C
         DO 20 J = 1, 4
            IF( ABS( CV( J ) ).GT.CMAX ) THEN
               CMAX  = ABS( CV( J ) )
               ICMAX = J
            END IF
   20    CONTINUE
C
         SMINI = MAX( SMIN, SMLNUM, EPS*CMAX )
C
C        If norm(C) < SMINI, use SMINI*identity.
C
         IF( CMAX.LT.SMINI ) THEN
            IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
               IF( BNORM.GT.BIGNUM*SMINI )
     $            SCALE = ONE / BNORM
            END IF
            TEMP = SCALE / SMINI
C
            DO 30 I = 1, M
               B( 1, I ) = TEMP*B( 1, I )
               B( 2, I ) = TEMP*B( 2, I )
   30       CONTINUE
C
            IWARN = 1
            RETURN
         END IF
C
C        Gaussian elimination with complete pivoting.
C
         U11  = CV( ICMAX )
         C21  = CV( IPIVOT( 2, ICMAX ) )
         U12  = CV( IPIVOT( 3, ICMAX ) )
         C22  = CV( IPIVOT( 4, ICMAX ) )
         U11R = ONE / U11
         L21  = U11R*C21
         U22  = C22 - U12*L21
C
C        If smaller pivot < SMINI, use SMINI.
C
         IF( ABS( U22 ).LT.SMINI ) THEN
            U22   = SMINI
            IWARN = 1
         END IF
C
         SCALEP = ONE
C
         DO 50 I = 1, M
            IF( RSWAP( ICMAX ) ) THEN
               B1 = B( 2, I )
               B2 = B( 1, I )
            ELSE
               B1 = B( 1, I )
               B2 = B( 2, I )
            END IF
            B2   = B2 - L21*B1
            BBND = MAX( ABS( B1*( U22*U11R ) ), ABS( B2 ) )
            IF( BBND.GT.ONE .AND. ABS( U22 ).LT.ONE ) THEN
               IF( BBND.GE.BIGNUM*ABS( U22 ) )
     $            SCALE = ONE / BBND
            END IF
            SCALE = MIN( SCALE, SCALEP )
            IF( SCALE.LT.SCALEP ) THEN
               SCALEP = SCALE / SCALEP
C
               DO 40 J = 1, I - 1
                  B( 1, J ) = B( 1, J )*SCALEP
                  B( 2, J ) = B( 2, J )*SCALEP
   40          CONTINUE
C
            END IF
C
            X2 = ( B2*SCALE ) / U22
            X1 = ( SCALE*B1 )*U11R - X2*( U11R*U12 )
            IF( ZSWAP( ICMAX ) ) THEN
               B( 1, I ) = X2
               B( 2, I ) = X1
            ELSE
               B( 1, I ) = X1
               B( 2, I ) = X2
            END IF
            XNORM = MAX( ABS( X1 ), ABS( X2 ) )
C
C           Further scaling if  norm(A) norm(X) > overflow.
C
            IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
               IF( XNORM.GT.BIGNUM / CMAX ) THEN
                  TEMP  = CMAX / BIGNUM
                  B( 1, I ) = TEMP*B( 1, I )
                  B( 2, I ) = TEMP*B( 2, I )
                  SCALE = TEMP*SCALE
               END IF
            END IF
            SCALEP = SCALE
   50    CONTINUE
C
      END IF
C
      RETURN
C
C *** Last line of MB02UW ***
      END

max_stars_repo_name: bgin/MissileSimulation

max_issues_repo_name: bgin/MissileSimulation

max_forks_repo_name: bgin/MissileSimulation


text: The Community of Silos Message is a peaceoriented Spiritual Organizations spiritual organization. It revolves around the writing of Silo, an Argentinian author, peace advocate and spiritual guide.

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
program test_functional_derivative_fft

! The same as test_functional_derivative but using FFT

use types, only: dp
use constants, only: i_
use ofdft, only: read_pseudo
use ofdft_fft, only: free_energy, radial_potential_fourier, &
    reciprocal_space_vectors, free_energy_min, real2fourier, integral, &
    fourier2real, real_space_vectors
use constants, only: Ha2eV
use utils, only: loadtxt, stop_error, assert, linspace
use splines, only: spline3pars, iixmin, poly3, spline3ders
use interp3d, only: trilinear
use md, only: positions_fcc
use converged_energies, only: four_gaussians_min
implicit none
real(dp) :: Eee, Een, Ts, Exc, Etot, Etot_conv
integer :: Ng
real(dp) :: Z
real(dp), allocatable :: R(:), G(:, :, :, :), G2(:, :, :)
real(dp), allocatable :: ne(:, :, :), Hn(:, :, :)
real(dp), allocatable :: Ven0G(:, :, :), current(:,:,:,:), Xn(:,:,:,:)
real(dp) :: V0
complex(dp), allocatable, dimension(:,:,:) :: VenG, psi, psi2, psi3, psiG, tmp
complex(dp), allocatable, dimension(:,:,:,:) :: dpsi
real(dp) :: L, T_eV, T_au
integer :: i, j
integer, parameter :: natom = 4
real(dp) :: X(3, natom), alpha_nen, mu, dt, psi_norm
integer :: cg_iter
real(dp) :: E0, t, omega, current_avg(3), conductivity

Ng = 32

L = 2
T_eV = 0.0862_dp
T_au = T_ev / Ha2eV

alpha_nen = 6

Z = 1

allocate(Ven0G(Ng, Ng, Ng), VenG(Ng, Ng, Ng), ne(Ng, Ng, Ng), Hn(Ng, Ng, Ng))
allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng), psi(Ng, Ng, Ng))
allocate(R(40000), psi2(Ng, Ng, Ng), psi3(Ng, Ng, Ng), psiG(Ng, Ng, Ng))
allocate(dpsi(Ng, Ng, Ng, 3), current(Ng, Ng, Ng, 3), tmp(Ng, Ng, Ng))
allocate(Xn(Ng, Ng, Ng, 3))
R = linspace(1._dp/40000, 0.9_dp, 40000)
print *, "Radial nuclear potential FFT"
call radial_potential_fourier(R, Z*erf(alpha_nen*R)/R, L, Z, Ven0G, V0)
print *, "    Done."

call real_space_vectors([L, L, L], Xn)
call reciprocal_space_vectors([L, L, L], G, G2)
call positions_fcc(X, L)
VenG = 0
do i = 1, natom
    VenG = VenG - Ven0G * exp(-i_ * &
        (G(:,:,:,1)*X(1,i) + G(:,:,:,2)*X(2,i) + G(:,:,:,3)*X(3,i)))
end do

! Minimization

ne = natom / L**3
call free_energy_min(real(natom, dp), natom, L, G2, T_au, VenG, ne, &
    1e-12_dp, Eee, Een, Ts, Exc, Etot, cg_iter)

Etot_conv = sum(four_gaussians_min)
print *, "Summary of energies [a.u.]:"
print "('    Ts   = ', f14.8)", Ts
print "('    Een  = ', f14.8)", Een
print "('    Eee  = ', f14.8)", Eee
print "('    Exc  = ', f14.8)", Exc
print *, "   ---------------------"
print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV
print *, "Errors:"
print *, abs(Ts - four_gaussians_min(1))
print *, abs(Een - four_gaussians_min(2))
print *, abs(Eee - four_gaussians_min(3))
print *, abs(Exc - four_gaussians_min(4))
print *, abs(Etot - Etot_conv)
call assert(abs(Ts - four_gaussians_min(1)) < 1e-7_dp)
call assert(abs(Een - four_gaussians_min(2)) < 1e-7_dp)
call assert(abs(Eee - four_gaussians_min(3)) < 1e-8_dp)
call assert(abs(Exc - four_gaussians_min(4)) < 1e-8_dp)
call assert(abs(Etot - Etot_conv) < 1e-10_dp)

call free_energy(L, G2, T_au, VenG, ne, Eee, Een, Ts, Exc, Etot, Hn, &
    calc_value=.true., calc_derivative=.true.)

mu = sum(Hn)/size(Hn)
print *, "mu = ", mu
print *, "max(abs(H-mu)) = ", maxval(abs(Hn - mu))
call assert(all(ne > 0))

print *
print *, "------------------------------------------------------------------"
print *, "Propagation"

! Propagate

print *, "E_max =", maxval(abs(Hn)), "; dt <", 1/maxval(abs(Hn))
dt = 1/maxval(abs(Hn)) / 10 ! set dt 10x smaller than the limit
print *, "dt =", dt

! Do first step by hand:
print *, "First step"
psi = sqrt(ne)

t = 0

psi2 = psi
psi = psi2 - i_*dt*Hn*psi2

ne = real(psi*conjg(psi), dp)
psi_norm = integral(L, ne)
print *, "Initial norm of psi:", psi_norm
psi = sqrt(natom / psi_norm) * psi
ne = real(psi*conjg(psi), dp)
psi_norm = integral(L, ne)
print *, "norm of psi:", psi_norm

E0 = 1e-3_dp
omega = 0.05

do i = 1, 10
    t = t + dt
    print *, "iter =", i, "time =", t
    psi3 = psi2; psi2 = psi
    psi = psi3 - 2*i_*dt*(Hn + E0*Xn(:,:,:,1)*sin(omega*t))*psi2
    ne = real(psi*conjg(psi), dp)
    call real2fourier(psi, psiG)
    psiG(1,1,1) = 0
    do j = 1, 3
        call fourier2real(i_*G(:,:,:,j)*psiG, dpsi(:,:,:,j))
        tmp = (conjg(psi)*dpsi(:,:,:,j)-psi*conjg(dpsi(:,:,:,j))) / (2*natom*i_)
        if (maxval(abs(aimag(tmp))) > 1e-12_dp) then
            print *, "INFO: current  max imaginary part:", maxval(aimag(tmp))
        end if
        current(:,:,:,j) = real(tmp, dp)
    end do

    psi_norm = integral(L, ne)
    print *, "norm of psi:", psi_norm

    call free_energy(L, G2, T_au, VenG, ne, Eee, Een, Ts, Exc, Etot, Hn, &
        calc_value=.true., calc_derivative=.true.)
    Etot = Ts + Een + Eee + Exc
    print *, "Summary of energies [a.u.]:"
    print "('    Ts   = ', f14.8)", Ts
    print "('    Een  = ', f14.8)", Een
    print "('    Eee  = ', f14.8)", Eee
    print "('    Exc  = ', f14.8)", Exc
    print *, "   ---------------------"
    print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV

    do j = 1, 3
        current_avg(j) = integral(L, current(:, :, :, j))/L**3
    end do
    print *, "E field along the 'x' direction =", E0*sin(omega*t)
    print *, "average current =", current_avg
    print *, "current normalized =", current_avg / current_avg(1)
    conductivity = current_avg(1) / E0*sin(omega*t)
    print *, "conductivity along the 'x' direction =", conductivity

end do
print *, "Done"

end program

max_stars_repo_name: certik/hfsolver

max_issues_repo_name: certik/hfsolver

max_forks_repo_name: certik/hfsolver


text:
program compute_distances
    use, intrinsic :: iso_fortran_env, only : DP => REAL64, &
                                              input_unit, error_unit
    implicit none
    real(kind=DP) :: x1, y1, x2, y2
    integer :: status
    character(len=1024) :: msg

    do while (.true.)
        read (unit=input_unit, fmt=*, iostat=status, iomsg=msg) &
            x1, y1, x2, y2
        if (status < 0) exit
        if (status > 0) then
            write (unit=error_unit, fmt='(2A)') &
                'I/O error: ', msg
            stop 1
        end if
        print *, distance(x1, y1, x2, y2)
    end do

contains

    function distance(x1, y1, x2, y2) result(d)
        implicit none
        real(kind=DP), intent(in) :: x1, y1, x2, y2
        real(kind=DP) :: d

        d = sqrt((x1 - x2)**2 + (y1 - y2)**2)
    end function distance

end program compute_distances

max_stars_repo_name: caguerra/Fortran-MOOC

max_issues_repo_name: caguerra/Fortran-MOOC

max_forks_repo_name: caguerra/Fortran-MOOC


text:
This page is a guide on how to spread knowledge via modern media in a sustainable education model.
The original seed of information derives from work done by a student Action Research Team as part of Education for Sustainable Living Program lecture series organized by California Student Sustainability Coalition at UC Davis in 2007. While this page started as a class project, please feel free to add any additional information you may know that would benefit other trying to use this guide.

Goals:
 1. To promote the open exchange and transmission of ideas by recording each of the lectures in video and audio for the quarter and putting them online for the public’s use.
 2. To create a manual for future classes/organizations to use as a guide for media casting.

The instructions below reflect what the team learned in the process of producing weekly video and audio files of each lecture with a final DVD of all the lectures at the end of the season. Right now were still trying to find a permanent web host to keep the files and toying with alternative distribution methods.

Why not call it Podcast: Basically Apple is currently trying exert a claim over anything with the word pod in it and we want to avoid that whole mess. Its really a poor word anyways since an iPod is not required in order to view any of the files produced through these methods.

 Sustainability in Education
 Knowledge is a resource to be shared for the continual maintenance and improvement of society. Everyone should have equal access to the same body of human knowledge to with it what they want. Just because some people pay (college students) to fund the improvement of knowledge doesnt mean that others should be deprived of these advancements, especially when it comes to public education institutions who exist for the betterment of society. (Oddly private universities are leading the charge on making knowledge an open resource)
   The Center for Open Sustainable Learning http://cosl.usu.edu/about
   MITs OpenCourseWare http://ocw.mit.edu/index.html
   OpenCourseWare Consortium http://www.ocwconsortium.org/

 Sustainability in Technology
 By creating and perpetuating software that is open to all for use however they choose, we ensure that future users of the software will have the same opportunities and tools available to them. Through participation in the community based model of software development we encourage and foster rapid innovation that leads to useful tools for everyone. (who has access to a computer, which is a different social issue)
   Free Software Foundation http://www.fsf.org/
   Open Source Initiative http://www.opensource.org/

 Tool List
  A Video Camera
  A Computer with a decent CPU and lots of hard disk space ( 24GB per 2 hours of video) plus extra room for converting formats.
  DVD Burner or Fast Internet Connection depending on how you plan to distribute the files.
  Software to (You can get all of these for free like we did, just keep reading):
   Capture Video
   Convert Video
   Make title screens and Menus

Licensing
 Why
 Before being able to record each lecture, we needed to choose a licensing format to protect the lectures so that they would remain available to the public, as well as to protect the rights of the lecturers.

 Software
 We attempted to use nothing but Free Open Source software most commonly licensed under a http://en.wikipedia.org/wiki/GPL General Public License in order to ensure that anyone in the world could repeat our steps

 Content
 We chose to use Creative Commons (http://www.creativecommons.org), a nonprofit licensing group that offered multiple varied licenses to protect works. Among these, we chose to use the Creative Commons License called the “Creative Commons AttributionNonCommercialShareAlike 2.0 Unported License”, which has since been updated to the 3.0 version, and can be found at (http://creativecommons.org/licenses/byncsa/3.0/). By using this specific license, it is acceptable to “copy, distribute, and transmit the work”, and to “adapt the work”, under three conditions. The first condition, “Attribution”, states that you first attribute the work in the manner that the author or licensor. The second condition, “Noncommercial”, states the work cannot be used for profit, and the third condition, “Sharealike” states “If you alter, transform, or build upon this work, you may distribute the resulting work only under the same or similar license to this one.” There are multiple other options available to potentially use, but this license gives the most freedoms to work with the podcasts, both for us and for other viewers.

After choosing the license, we had to get each of the lecturers to agree to the license conditions. We sent out emails to each of the lecturers in advance to inform them of our intentions and give them time to think it through or search of a feasible alternative that they might prefer.
Filming
 Camera
  Generally a video camera that uses miniDV is the most common format. Alternately there are camcorders out there that record to VHS, super8, minidisc or hard drives. Minidv and other digital format camcorders typically have an i1394 port(mini) aka Firewire. Depending on your computer youll need either a mini(4pin) to mini(4pin) (usually laptops) or a mini to 6pin(Desktop)
Links to examples...
In the case of miniDV we found that 80min tapes set to record on EP(Extended Play or LP Long Play) will record 120minutes at good enough quality for computer playback.
 Accessories
   Tripod : use a tripod your video will come out much better
   Power Adapter or Battery :  Dont forget to plan to power your camera, if your batteries are more than 3 years old think about getting a new one. Always have a backup plan(ie extension cord, spare, etc)
 Audio Recording
 Consider recording your audio separately, youll have more control over the placement of the microphone which greatly influence the quality. You can use an recording device, digital is recommended to save you the step of having to convert it later. If using a computer to the recording Audacity or VLC work well.

Converting to Digital
 Tool List
   Firewire Cable :
     4pin to 4pin  Camera to Small Port(Usually Laptop)
     4pin to 6pin  Camera to Large Port(Usually Desktop)
   Hard Drive Space 5min ≈ 1GB, which means 2 hours of video equals 24 GB

 Conversion
 Plug in your camera to your computer and turn it on to play/vcr mode. Then use one of the tools below to capture the video. Note unless you have a really cool camera that doesnt use tapes youre stuck at a 1:1 copy speed, which means it will take as long as the recording is to copy.
 || Linux || dvgrab  || http://www.kinodv.org/ || Command line example:$ sudo dvgrab timestamp format dv2 opendml size 2048 ||
 || Windows || virutaldub ||  http://www.virtualdub.org/ || Graphical Interface ||
 || Mac || || || ||

Encoding to Playable Formats
 Playable by who?
 You obviously cant go around giving people a 24GB video to watch, at least not with the current technology. For a home DVD burner the standard disc has 4.7GB so thats the maximum you should really work with(minus a little for menus, extras and overhead of writing the disc 4.5GB should be plenty of room)

 Encoding
 Sometimes called transcoding its the process of converting the video from one format to another. Depending on how much you like the command line and how many files you want to convert there are lots of software choices.

For this project we used a mix of the following which are all available for every OS in one form or another:
  Avidemux
   Graphical Tool  usable but not necessarily intuitive, has a lot of features to make the advanced user happy but isnt great for batching files.
   http://fixounet.free.fr/avidemux/

  mencoder
   Command Line  once you get a good command set you like its easy to repeat, check out my script file(MencoderExample.script) (Hint: its a text file, you can open it with any text editor) for converting all avi files in a folder to mpeg2 DVD format, compressing to make sure 2 hours will fit on 1 DVD.
   http://www.mplayerhq.hu/design7/news.html

 Handbrake
    Graphical Tool  Recommeded tool as it has common format presets. Fairly easy to use but occasionally doesnt like some input formats but does a fantastic job on compression.

You can also use:
  ffmpeg

They actually all borrow from each other, ffmpeg is embedded in Avidemux and mencoder for certain formats.

Distribution

Why not streaming media?: Its an option and people should feel free to explore, we didnt have complete access to a server where we could test all the possibilities. Its also a difficult task to tackle since Flash, Quicktime and RealMedia are all proprietary tools for embedding media in a webpage and that would exceed our budget and moral guidelines.

2011 Update: http://youtube.com Youtube and http://vimeo.com Vimeo provide reasonable options for this, though http://creativecommons.org Creative Commons integration is not perfect. The best part is that both of these sites will take most common formats and convert them into web optimized formats.

 Making an AudioCast
 ||Format  Options|| Pro || Con ||
 ||mp3|| Widely used, especially on devices || Proprietary Format ||
 ||wmv||  || Proprietary Format, Mostly available only to Windows users, Not supported on many devices||
 ||aac|| Widely used, sometimes on devices || Not supported on many devices ||
 ||ogg|| Free Open Source || Most people dont have the codec for it yet, Not supported on many devices ||
 Quality and compression is really about the same with all the formats. We choose mp3 simply because it would be the most widely compatible and the only format the would work with the http://podcast.ucdavis.edu UC Davis podcast site

 Making a VideoCast
 Making Video files becomes more complicated because there are 2 things you need pay attention to. The video format, which is the codec used to encode the stream, and the container which is the file format that you put your stream into. A good way to think of it is like a box, only certain things fit in the box and you need certain tools to open the box and not all boxes fit the same things or can be opened the same way.

 ||Container  Options|| Pro || Con ||
 || .avi || Widely compatible || Not Podcastable via http://podcast.ucdavis.edu UC Davis podcast site ||
 || .mp4 || The latest standard with good compression || A huge standard that is never fully implemented, making it hard to find the right settings ||
 || .mp2, mpeg2 || Widely Compatible, Standard format for DVDs || Not very efficient, doesnt go into a .mp4 ||
 || .ogg || Open Source || Not widely adopted. ||

 || Video Format  Options|| Pro || Con ||
 || x264 || Open Source implementation of h264 standard used by Apple for mp4 || Doesnt play nice with Quicktime out of the box ||
 || h263 || || ||
 || xvid || || ||

 || Audio Format  Options|| Pro || Con ||
 || .mp3 || Widely used, especially on devices || Proprietary Format ||
 || .aac || Widely used, especially on devices || Proprietary Format, Not as common as mp3 when used alone. ||
 || .ogg || Open Source || Not widely adopted. ||

 Making a DVD
   Formatting : The accepted DVD standard is mpeg2 formatting 720x480 with aac? Audio formating at 48000 kHz(Note this is higher than normal audio on minidv formats)
   Media : DVDR (4.7GB) work well with home DVD burners and are compatible with most industry standard DVD players.
   Menus : DVDStyler http://www.dvdstyler.de/

Archiving on the Internet
So it turns out that fitting 20 hrs of TV quality imagery on a single DVD is well, impossible. What were going for now is to upload the individual DVDs (4GB+) each to the http://www.archive.org/index.php Internet Archive and uploaded each of the individual audio files of the same lecture to the same site. Links will be posted as soon as the files are uploaded.


text:
MODULE PE2D_GROUND
 USE PE2D_TYPE
 IMPLICIT NONE
 !-----------------------------------------------------------
 CONTAINS
 !-----------------------------------------------------------
 !Gaussian Hill (Default)
 FUNCTION GHILL(H0,X0,S,X) RESULT(GH)
 IMPLICIT NONE
 REAL(DP), INTENT(IN) :: H0, x0, s, x
 REAL(DP) :: GH(3)
 GH(1) = H0*(EXP(-(X-X0)**2/(S**2))-EXP(-(X0/S)**2))
 GH(2) = -2*(H0/S**2)*(X-X0)*EXP(-(X-X0)**2/(S**2))
 GH(3) = 2*(H0/S**2)*((X-X0)**2/(S**2)-1)*EXP(-(X-X0)**2/(S**2))
 END FUNCTION GHILL
 !-----------------------------------------------------------
 !Symmetric Triangular Hill
 FUNCTION STHILL(H0,X0,D,X) RESULT(STH)
 IMPLICIT NONE
 REAL(DP), INTENT(IN) :: H0, X0, D, X
 REAL(DP) :: STH
 STH = 0.
 IF ((X.LE.(X0-D)).OR.(X.GE.(X0+D))) THEN
  STH = 0
 ELSEIF (X.LE.X0) THEN
  STH = H0*((X-X0)/D+1)
 ELSEIF (X.GT.X0) THEN
  STH = H0*((X0-X)/D+1)
 ENDIF
 END FUNCTION STHILL
 !-----------------------------------------------------------
 !Unsymmetric Triangular Hill
 FUNCTION THILL(H0,X0,D1,D2,X) RESULT(TH)
 IMPLICIT NONE
 REAL(DP), INTENT(IN) :: H0, X0, D1, D2, X
 REAL(DP) :: TH
 TH = 0.
 IF ((X.LE.(X0-D1)).OR.(X.GE.(X0+D2))) THEN
  TH = 0
 ELSEIF (X.LE.X0) THEN
  TH = H0*((X-X0)/D1+1)
 ELSEIF (X.GT.X0) THEN
  TH = H0*((X0-X)/D2+1)
 ENDIF
 END FUNCTION THILL
 !-----------------------------------------------------------
 !Rectangular Hill
 FUNCTION RHILL(H0,X1,X2,X) RESULT(RH)
 IMPLICIT NONE
 REAL(DP), INTENT(IN) :: H0, X1, X2, X
 REAL(DP) :: RH
 RH = 0
 IF ((X.LT.X1).OR.(X.GT.X2)) THEN
  RH = 0
 ELSE
  RH = H0
 ENDIF
 END FUNCTION RHILL
 !-----------------------------------------------------------
 !Slope
 FUNCTION SLOPE(H1,H2,X1,X2,X) RESULT(SLP)
 IMPLICIT NONE
 REAL(DP), INTENT(IN) :: H1, H2, X1, X2, X
 REAL(DP) :: SLP
 SLP = 0
 IF ((X.LT.X1).OR.(X.GT.X2)) THEN
  SLP = 0
 ELSE
  SLP = ((H2-H1)*X+X2*H1-X1*H2)/(X2-X1)
 ENDIF
 END FUNCTION SLOPE
 !-----------------------------------------------------------
 !FUNCTION REALTERR(ITERR) RESULT(TERR)
 !IMPLICIT NONE
 !INTEGER(I4B), INTENT(IN) :: ITERR
 !INTEGER(I4B) :: M, I
 !REAL(DP), DIMENSION() ::
 !END FUNCTION REALTERR
 !-----------------------------------------------------------
END MODULE PE2D_GROUND

max_stars_repo_name: codorkh/AcousticPE

max_issues_repo_name: codorkh/infratopo

max_forks_repo_name: codorkh/infratopo


text:
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

module flang3
use, intrinsic :: iso_c_binding

type, bind(c) :: bar
integer(c_int) :: bar1 = -1
end type bar

type, bind(c) :: zip
type(bar) :: zip1
end type zip

type, bind(c) :: roo
integer(c_int),dimension(99) :: roo1 = 0
type(zip) :: roo2(0:98)
end type roo

type(roo), public, target, dimension(0:98), bind(c) :: foo
save :: foo

end module

SUBROUTINE MOO
USE flang3
DO m=1,2
write (*,*) foo(m)%roo2
END DO
END SUBROUTINE

print *, "PASS"
end

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
module linalg_feast
use types, only: dp
use utils, only: stop_error, assert
use feast, only: feastinit, dfeast_syev, dfeast_sygv_orig => dfeast_sygv, &
    dfeast_srci
use lapack, only: xerbla, zcopy, zgetrf, zgetrs, dgemm, dsymm
use petsc_, only: petsc_init, petsc_finalize, solve
implicit none
private
public eigh

interface eigh
    module procedure deigh_generalized
    module procedure deigh_simple
end interface eigh

contains

subroutine deigh_generalized(A, B, Emin, Emax, M0, lam, c)
real(dp), intent(in) :: A(:, :), B(:, :), Emin, Emax
integer, intent(in) :: M0
real(dp), allocatable, intent(out) :: lam(:), c(:, :)
integer :: feastparam(64)
real(dp), allocatable :: res(:), lam_(:), c_(:, :)
real(dp) :: epsout
integer :: i, loop, info, M, N, LDA
N = size(A, 1)
LDA = N
allocate(lam_(M0), c_(N, M0), res(M0))

call feastinit(feastparam)
feastparam(1)=1 !! change from default value
feastparam(2) = 4  !! Nq
feastparam(3) = 5  !! accuracy: 1e-x
!call dfeast_sygv('L',N,A,LDA,B,LDA,feastparam,epsout,loop,Emin,Emax,M0, &
!    lam_,c_,M,res,info)
call dfeast_sygv_orig('L',N,A,LDA,B,LDA,feastparam,epsout,loop,Emin,Emax,M0, &
    lam_,c_,M,res,info)

if (info /= 0) then
    print *,'FEAST OUTPUT INFO', info
    call stop_error("info /= 0")
end if

print *, '# Search interval [Emin,Emax]', Emin, Emax
print *, '# mode found/subspace', M, M0
print *, '# iterations', loop
print *, 'TRACE', sum(lam_(1:M))
print *, 'Relative error on the Trace', epsout
print *, 'Eigenvalues/Residuals'
do i = 1, M
    print *, i, lam_(i), res(i)
end do

allocate(lam(M), c(N, M))
lam = lam_(:M)
c = c_(:, :M)

end subroutine

subroutine deigh_simple(A, Emin, Emax, M0, lam, c)
real(dp), intent(in) :: A(:, :), Emin, Emax
integer, intent(in) :: M0
real(dp), intent(out) :: lam(:), c(:, :)
integer :: feastparam(64)
real(dp), allocatable :: res(:)
real(dp) :: epsout
integer :: i, loop, info, M, N, LDA
N = size(A, 1)
LDA = N
allocate(res(M0))

call feastinit(feastparam)
feastparam(1)=1 !! change from default value
call dfeast_syev('F',N,A,LDA,feastparam,epsout,loop,Emin,Emax,M0,lam,c, &
    M,res,info)

if (info /= 0) then
    print *,'FEAST OUTPUT INFO', info
    call stop_error("info /= 0")
end if

print *, '# Search interval [Emin,Emax]', Emin, Emax
print *, '# mode found/subspace', M, M0
print *, '# iterations', loop
print *, 'TRACE', sum(lam(1:M))
print *, 'Relative error on the Trace', epsout
print *, 'Eigenvalues/Residuals'
do i = 1, M
    print *, i, lam(i), res(i)
end do

if (M < M0) call stop_error("M < M0")

end subroutine

subroutine dfeast_sygv(UPLO,N,A,LDA,B,LDB,fpm,epsout,loop,Emin,Emax,M0,E,X,mode,res,info)
  !  Purpose
  !  =======
  !  FEAST DENSE INTERFACE
  !  Solve the generalized Ax=eBx eigenvalue problem
  !
  !  A REAL SYMMETRIC, B SYMMETRIC POSITIVE DEFINITE:: DENSE FORMAT
  !
  !  DOUBLE PRECISION version
  !
  !  Arguments
  !  =========
  !
  !  UPLO       (input)       character: specifies whether the full part, or the upper or lower
  !                           triangular part of the matrix(ces) is(are) being supplied.
  !  N          (input)        INTEGER: Size system
  !  A          (input)        REAL DOUBLE PRECISION (LDA,N):  Matrix A
  !  LDA        (input)        INTEGER: Leading dimension of matrix A (LDA>=N)
  !  B          (input)        REAL DOUBLE PRECISION (LDB,N):  Matrix B
  !  LDB        (input)        INTEGER: Leading dimension of matrix B (LDB>=N)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! LIST of FEAST ARGUMENTS COMMON TO ALL FEAST INTERFACES
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  fpm (input/output) INTEGER(*) : FEAST parameters
  !  epsout     (output)       REAL DOUBLE PRECISION : Error on the trace
  !  loop       (output)       INTEGER : # of iterative loop to reach convergence
  !  Emin,Emax  (input)        REAL DOUBLE PRECISION: search interval
  !  M0         (input/output) INTEGER: Size subspace
  !  lambda     (output)       REAL DOUBLE PRECISION(M0)   : Eigenvalues -solution
  !  q          (input/output) REAL DOUBLE PRECISION(N,M0) :
  !                                                       On entry: subspace initial guess if fpm(5)=1
  !                                                       On exit : Eigenvectors-solution
  !  mode       (output)       INTEGER : # of eigenvalues found in the search interval
  !  res        (output)       REAL DOUBLE PRECISION(M0) : Relative Residual of the solution (1-norm)
  !                                                        if option fpm(6)=1 selected
  !  info       (output)       INTEGER: Error handling (0: successful exit)
  !=====================================================================
  ! Eric Polizzi 2009-2012
  ! ====================================================================
  character(len=1) :: UPLO
  integer :: N,LDA,LDB
  double precision,dimension(LDA,*):: A
  double precision,dimension(LDB,*):: B
  integer,dimension(*) :: fpm
  double precision :: epsout
  integer :: loop
  double precision :: Emin,Emax
  integer :: M0
  double precision,dimension(*)  :: E
  double precision,dimension(N,*):: X
  integer :: mode
  double precision,dimension(*)    :: res
  integer :: info

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  integer :: ijob,infoloc
  integer :: ierr!, i
  complex(kind=(kind(1.0d0))) :: Ze
  complex(kind=(kind(1.0d0))), dimension(:,:),pointer ::workc,Az
  double precision, dimension(:,:),pointer ::work,Aq,Sq
  integer, dimension(:),pointer ::ipivloc
  double precision,parameter :: DONE=1.0d0,DZERO=0.0d0
  complex(kind=(kind(1.0d0))),parameter :: ONEC=(DONE,DZERO)

  INFO = 0
  IF ((UPLO/='F').and.(UPLO/='f').and.(UPLO/='L').and.(UPLO/='l').and.(UPLO/='U').and.(UPLO/='u')) THEN
     INFO=-101
  ELSE IF ( N<=0 ) THEN
     INFO = -102
  ELSE IF(LDA<N ) THEN
     INFO = -104
  ELSE IF(LDB<N ) THEN
     INFO = -106
  END IF
  IF( INFO.NE.0 ) THEN
     CALL XERBLA( 'DFEAST_SYGV', -INFO+100 )
     RETURN
  END IF
  infoloc=0
  allocate(Aq(M0,M0), Sq(M0, M0), work(N, M0), workc(N, M0), ipivloc(N))
  allocate(Az(N, N))
  ierr = petsc_init()

  if (infoloc/=0) then
     info=-1
     return
  end if
!!$
  ijob=-1 ! initialization
  do while (ijob/=0)
      call dfeast_srci(ijob,N,Ze,work,workc,Aq,Sq,fpm,epsout,loop,Emin,Emax,M0,E,X,mode,res,info)
     select case(ijob)
     case(10) !! factorize (zeB-A)
        Az(1:N,1:N)=Ze*B(1:N,1:N)-A(1:N,1:N)*ONEc

        print *, "Factorization (zgetrf) N =", N
        call ZGETRF(N,N,Az,N,IPIVloc,INFOloc)
        print *, "Done"
        if (infoloc/=0) then
           info=-2
           return
        end if

     case(11) !!solve the linear system (ZeB-A)x=workc(1:N,1:M0) result in to workc

        print *, "Solve (zgetrs) N =", N
!        do i = 1, M0
!            print *, i
!            ierr = solve(N, Az, workc(:, i), workc(:, i))
!        end do
        call ZGETRS( 'N', N, M0, Az, N, IPIVloc, workc, N, INFOloc )
        print *, "Done"
        if (infoloc/=0) then
           info=-2
           return
        end if

     case(30) !! perform multiplication A*x(1:N,fpm(24):fpm(24)+fpm(25)-1) result in work(1:N,fpm(24)+fpm(25)-1)

        if ((UPLO=='F').or.(UPLO=='f')) then
           call DGEMM('N','N',N,fpm(25),N,DONE,A,LDA,X(1,fpm(24)),N,DZERO,work(1:N,fpm(24)),N)
        else
           call DSYMM ('L', UPLO, N, fpm(25), DONE, A, LDA, X(1,fpm(24)), N, DZERO,work(1:N,fpm(24)), N)
        endif

     case(40) !! perform multiplication B*x(1:N,fpm(24):fpm(24)+fpm(25)-1) result in work(1:N,fpm(24)+fpm(25)-1)

        if ((UPLO=='F').or.(UPLO=='f')) then
           call DGEMM('N','N',N,fpm(25),N,DONE,B,LDB,X(1,fpm(24)),N,DZERO,work(1:N,fpm(24)),N)
        else
           call DSYMM ('L', UPLO, N, fpm(25), DONE, B, LDB, X(1,fpm(24)), N, DZERO,work(1:N,fpm(24)), N)
        endif

     end select
  end do

  ierr = petsc_finalize()

end subroutine dfeast_sygv

end module


!
!Copyright 2005-2019 ECMWF.
!
! This software is licensed under the terms of the Apache Licence Version 2.0
!which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!
!
! FORTRAN 90 implementation: bufr_copy_data
!
! Description: How to copy all the values in the data section that are present in the same
!              position in the data tree and with the same number of values to the output handle
!
!

program bufr_encode
  use eccodes
  implicit none
  integer                                       :: iret
  integer                                       :: outfile
  integer                                       :: ifile
  integer                                       :: ibufr
  integer                                       :: ibufrin
  integer(kind=4), dimension(:), allocatable    :: ivalues
  integer, parameter                            :: max_strsize = 200
  character(len=max_strsize)                    :: infile_name
  character(len=max_strsize)                    :: outfile_name

  call codes_bufr_new_from_samples(ibufr,'BUFR3',iret)
  call getarg(1, infile_name)
  call getarg(2, outfile_name)
  call codes_open_file(ifile, infile_name, 'r')
  call codes_bufr_new_from_file(ifile, ibufrin)

  if (iret/=CODES_SUCCESS) then
    print *,'ERROR creating BUFR from BUFR3'
    stop 1
  endif
  if(allocated(ivalues)) deallocate(ivalues)
  allocate(ivalues(69))
  ivalues=(/   &
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0,   &
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0,   &
      0, 0, 0, 1, 1, 1, 1, 1, 1, 1,   &
      1, 1, 1, 1, 1, 1, 1, 1, 1, 1,   &
      1, 1, 1, 1, 1, 0, 1, 1, 1, 1,   &
      1, 1, 1, 1, 1, 1, 1, 1, 1, 1,   &
      1, 1, 1, 1, 1, 1, 1, 1, 0 /)
  call codes_set(ibufr,'inputDataPresentIndicator',ivalues)
  call codes_set(ibufr,'edition',3)
  call codes_set(ibufr,'masterTableNumber',0)
  call codes_set(ibufr,'bufrHeaderSubCentre',0)
  call codes_set(ibufr,'bufrHeaderCentre',98)
  call codes_set(ibufr,'updateSequenceNumber',1)
  call codes_set(ibufr,'dataCategory',0)
  call codes_set(ibufr,'dataSubCategory',140)
  call codes_set(ibufr,'masterTablesVersionNumber',13)
  call codes_set(ibufr,'localTablesVersionNumber',1)
  call codes_set(ibufr,'typicalYearOfCentury',15)
  call codes_set(ibufr,'typicalMonth',5)
  call codes_set(ibufr,'typicalDay',4)
  call codes_set(ibufr,'typicalHour',9)
  call codes_set(ibufr,'typicalMinute',30)
  call codes_set(ibufr,'numberOfSubsets',1)
  call codes_set(ibufr,'observedData',1)
  call codes_set(ibufr,'compressedData',0)
  if(allocated(ivalues)) deallocate(ivalues)
  allocate(ivalues(43))
  ivalues=(/  &
    307011,7006,10004,222000,101023,31031,1031,1032,101023,33007, &
    225000,236000,101023,31031,1031,1032,8024,101001,225255,225000, &
    236000,101023,31031,1031,1032,8024,101001,225255, &
    1063,2001,4001,4002,4003,4004,4005,5002, &
    6002,7001,7006,11001,11016,11017,11002 /)
  call codes_set(ibufr,'unexpandedDescriptors',ivalues)

  call codes_set(ibufrin,'unpack',1)

  call codes_bufr_copy_data(ibufrin, ibufr)

  call codes_open_file(outfile,outfile_name,'w')
  call codes_write(ibufr,outfile)
  call codes_close_file(outfile)
  call codes_release(ibufr)
end program bufr_encode


text:
MODULE libraryModuleB
CONTAINS
        SUBROUTINE libB
        END SUBROUTINE
END MODULE

max_stars_repo_name: eWert-Online/esy-cmake

max_issues_repo_name: eWert-Online/esy-cmake

max_forks_repo_name: eWert-Online/esy-cmake


text:
*********************************************************
*AUTHOR: FABIO MALTONI                                  *
*DATE  : 10/10/2001                                     *
*NOTES : PROGRAM GENERATED BY BHIGGS.M                  *
*********************************************************

      double precision FUNCTION  BBAQH(I1,I2,I3,I4)
* ---------------------------------------------------------------------
* returns the matrix element squared for the process
*
*          0 -> bbar1 b2 a3 q4 h
*
* All momenta outgoing.
* No averaging is performed for initial spins or colors.
* No STRONG coupling is included.
* No Bottom-Higgs coupling is included.
* ---------------------------------------------------------------------

      IMPLICIT NONE
      INCLUDE 'constants.f'
      INCLUDE 'sprods_com.f'
      INCLUDE 'zprods_com.f'

*     ARGUMENTS
      INTEGER I1,I2,I3,I4

*     LOCAL
      double precision  T134,T234
      DOUBLE COMPLEX AMP(2)
      INTEGER L

      t134=s(i1,i3)+s(i1,i4)+s(i3,i4)
      t234=s(i2,i3)+s(i2,i4)+s(i3,i4)

      amp(1)=
     .   (-2d0*(za(i3,i2)*zb(i2,i1) + za(i3,i4)*zb(i4,i1))*zb(i4,i2))/
     -   (T234*s(i3,i4)) + (2d0*zb(i1,i4)*
     -     (za(i1,i3)*zb(i2,i1) - za(i4,i3)*zb(i4,i2)))/
     -   (T134*s(i3,i4))

      amp(2)=
     .   (-2d0*(za(i4,i2)*zb(i2,i1) + za(i4,i3)*zb(i3,i1))*zb(i3,i2))/
     -   (T234*s(i3,i4)) + (2d0*zb(i3,i1)*
     -     (za(i4,i1)*zb(i2,i1) - za(i4,i3)*zb(i3,i2)))/
     -   (T134*s(i3,i4))

      BBAQH=0d0
      do l=1,2
         BBAQH=BBAQH+cdabs(amp(l))**2
      enddo

      BBAQH=2D0*BBAQH*V/4d0

      END

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
	SUBROUTINE SF_DTIM  ( isffln, dattim, iret )
C************************************************************************
C* SF_DTIM								*
C*									*
C* This subroutine deletes a time from a surface file.  All the data	*
C* corresponding to the time will be deleted along with the header	*
C* storing the time.							*
C*									*
C* SF_DTIM  ( ISFFLN, DATTIM, IRET )					*
C*									*
C* Input parameters:							*
C*	ISFFLN		INTEGER		Surface file number		*
C*	DATTIM		CHAR*		GEMPAK date/time		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*				    	   0 = normal return		*
C*					  -3 = file not open		*
C*				  	 -13 = delete error		*
C**									*
C* Log:									*
C* I. Graffman/RDS	5/87						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GMBDTA.CMN'
C*
	CHARACTER*(*) 	dattim
C*
	CHARACTER	keynam (2)*4
	INTEGER		lowval (2), ihival (2)
	DATA		keynam /'DATE', 'TIME'/
C------------------------------------------------------------------------
	CALL SF_CHKF  ( isffln, iret )
	IF  ( iret .ne. 0 )  RETURN
C
C*	Break the time into 2 integers.
C
	CALL TI_IDTM  ( dattim, lowval (1), lowval (2), ier )
	DO  i = 1, 2
	    ihival (i) = lowval (i)
	END DO
C
C*	Delete row/column.
C
	CALL DM_DALL  ( isffln, 2, keynam, lowval, ihival, ier )
	IF  ( ier .ne. 0 )  THEN
	    CALL ER_WMSG  ( 'DM', ier, dattim, ierr )
	    iret = -13
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


module matrix_free

  use numeric_kinds, only: dp
  use davidson_free, only: free_matmul
  implicit none

  public mtx_gemv, stx_gemv, compute_stx_on_the_fly, compute_matrix_on_the_fly

contains

  function mtx_gemv(input_vect) result (output_vect)
    !> \brief Function to compute the optional mtx on the fly
    !> \param[in] i column/row to compute from mtx
    !> \param vec column/row from mtx

    real (dp), dimension(:,:), intent(in) :: input_vect
    real (dp), dimension(size(input_vect,1),size(input_vect,2)) :: output_vect

    output_vect = free_matmul(compute_matrix_on_the_fly,input_vect)

  end function mtx_gemv

  function stx_gemv(input_vect) result (output_vect)
    !> \brief Function to compute the optional mtx on the fly
    !> \param[in] i column/row to compute from mtx
    !> \param vec column/row from mtx

    real (dp), dimension(:,:), intent(in) :: input_vect
    real (dp), dimension(size(input_vect,1),size(input_vect,2)) :: output_vect

    output_vect = free_matmul(compute_stx_on_the_fly,input_vect)

  end function stx_gemv

    function compute_matrix_on_the_fly(i, dim) result (vector)
    !> \param[in] i index of the i-th column
    !> \param[in] dim dimension of the resulting column
    !> \return the i-th column of a square matrix of dimension dim

    integer, intent(in) :: i, dim
    real(dp), dimension(dim) :: vector

    ! local variable
    integer :: j
    real(dp) :: x, y

    x = exp(real(i)/real(dim))

    do j=1,dim
       y = exp(real(j)/real(dim))
       if (j >= i) then
          vector(j) = cos(log(sqrt(atan2(x, y)))) * 1e-4
       else
          vector(j) = cos(log(sqrt(atan2(y, x)))) * 1e-4
       endif
    end do

    vector(i) = vector(i) + real(i)

  end function compute_matrix_on_the_fly

  function compute_stx_on_the_fly(i, dim) result (vector)
    !> \param[in] i index of the i-th column
    !> \param[in] dim dimension of the resulting column
    !> \return the i-th column of a square matrix of dimension dim

    integer, intent(in) :: i, dim
    real(dp), dimension(dim) :: vector

    vector = 0d0
    vector(i) = 1d0

  end function compute_stx_on_the_fly

end module matrix_free

program main
  use numeric_kinds, only: dp
  use davidson, only: generalized_eigensolver
  use array_utils, only: generate_diagonal_dominant, norm
  use matrix_free, only: mtx_gemv, stx_gemv, compute_matrix_on_the_fly, compute_stx_on_the_fly

  implicit none

  integer, parameter :: dim = 1000
  integer, parameter :: lowest = 3
  real(dp), dimension(lowest) :: eigenvalues_DPR
  real(dp), dimension(dim, lowest) :: eigenvectors_DPR
  real(dp), dimension(dim) :: xs
  real(dp), dimension(dim, dim) :: mtx, stx
  integer :: iter_i, j

  do j=1, dim
     mtx(:, j) = compute_matrix_on_the_fly(j, dim)
     stx(:, j) = compute_stx_on_the_fly(j, dim)
  end do

  call generalized_eigensolver(mtx_gemv, eigenvalues_DPR, eigenvectors_DPR, &
       lowest, "DPR", 1000, 1d-8, iter_i, 20, stx_gemv)

  do j=1,lowest
     xs = matmul(mtx, eigenvectors_DPR(:, j)) - (eigenvalues_DPR(j) * matmul(stx, eigenvectors_DPR(:, j)))
     print *, "error: ", norm(xs)
     print *, "eigenvalue ", j, ": ", eigenvalues_DPR(j), " succeeded: ", norm(xs) < 1d-8
  end do

end program main


text:
program intrinsics_20
integer, parameter :: dp = kind(0.d0)
real, parameter :: pi = acos(-1.)
real(dp), parameter :: pi_dp = acos(-1._dp)

real, parameter :: x = cos((3+4)*7.)
integer :: y
integer, parameter :: y2 = 3

print *, pi
print *, pi_dp
print *, x
y = 3
print *, cos((3+4)*7.)
print *, cos((y+4)*7.)
print *, cos((y2+4)*7.)
print *, cos(x+1)**2 + sin(x+1)**2

end

max_stars_repo_name: Thirumalai-Shaktivel/lfortran

max_issues_repo_name: Thirumalai-Shaktivel/lfortran

max_forks_repo_name: Thirumalai-Shaktivel/lfortran


text:
module a_test
  implicit none

contains
  subroutine test_aaa
    assert_equals(1, 1, "asserts 1 is 1")
  end subroutine test_aaa

  subroutine test_aaa2nd
    assert_equals(3, 4, "asserts 3 is 4")
  end subroutine test_aaa2nd

  subroutine test_warned_if_argument(arg1)
  end subroutine test_warned_if_argument
end module a_test

max_stars_repo_name: thomasms/fortran-examples

max_issues_repo_name: thomasms/fortran-examples

max_forks_repo_name: thomasms/fortran-examples


text:
module Tools
  USE Inputs
  implicit none
  SAVE

contains

  !     Bin_Data subroutine enables the binning of data into a histogram
  !
  !
  !     ------------------------------Arguments-------------------------------------
  !
  !     HistoData: A 1xN array, where N is the number of bins in the histogram. This contains the histogram
  !
  !     Data: A 1xM array, where M is the number of contributions to be added to HistoData. Each element is the value of a contribution
  !
  !     Weights: A 1xM array containing the weights of each contribution in Data
  !              This argument is optional
  !
  !     Dropped: A variable of type integer that keeps track of the number of contributions outside of a specified range
  !              This argument is optional
  !
  !     Max/Min: The maximum (Max) and minimum (Min) values to be counted. Contributions outside are not counted
  subroutine Bin_Data( HistoData, Data, Weights, Dropped, Max, Min )
    implicit none
    real, dimension(:), intent(in) :: Data
    real, dimension(:), Optional, intent(in) :: Weights
    real, intent(inout) :: HistoData(bins)
    real, intent(in) :: Max
    real, intent(in) :: Min
    real, optional, intent(inout) :: Dropped
    integer Loop1, Loop2

    If ( Present(Dropped) .and. Present(Weights) ) then

       do Loop1 = 1,size(Data)
          if ( Weights(Loop1) .eq. 0 ) CYCLE
          if ( ( Data(Loop1) .lt. Min ) .or. ( Data(Loop1) .gt. Max ) ) then
             Dropped = Dropped + Weights(Loop1)
          else
             Loop2 = FLOOR(bins*(Data(Loop1) - Min)/(Max - Min) + 1)
             if ( (Loop2 .gt. bins) .or. (Loop2 .lt. 1) ) CYCLE
             HistoData(Loop2) = HistoData(Loop2) + Weights(Loop1)

          end if

       end do

    else if ( Present(Dropped) .and. (.not. Present(Weights) ) ) then

       do Loop1 = 1,size(Data)
          if ( ( Data(Loop1) .lt. Min ) .or. ( Data(Loop1) .gt. Max ) ) then
             Dropped = Dropped + Weights(Loop1)
          else
             Loop2 = FLOOR(bins*(Data(Loop1) - Min)/(Max - Min) + 1)
             if ( (Loop2 .gt. bins) .or. (Loop2 .lt. 1) ) CYCLE
             HistoData(Loop2) = HistoData(Loop2) + 1

          end if

       end do

    else if ( (.not. Present(Dropped)) .and. Present(Weights) ) then

       do Loop1 = 1,size(Data)
          if ( ( Data(Loop1) .lt. Min ) .or. ( Data(Loop1) .gt. Max ) ) CYCLE
          Loop2 = FLOOR(bins*(Data(Loop1) - Min)/(Max - Min) + 1)
          if ( (Loop2 .gt. bins) .or. (Loop2 .lt. 1) ) CYCLE
          HistoData(Loop2) = HistoData(Loop2) + Weights(Loop1)

       end do

    else if ( .not. ( Present(Dropped) .or. Present(Weights) ) ) then

       do Loop1 = 1,size(Data)
          if ( ( Data(Loop1) .lt. Min ) .or. ( Data(Loop1) .gt. Max ) ) CYCLE
          Loop2 = FLOOR(bins*(Data(Loop1) - Min)/(Max - Min) + 1)
          if ( (Loop2 .gt. bins) .or. (Loop2 .lt. 1) ) CYCLE
          HistoData(Loop2) = HistoData(Loop2) + 1

       end do

    else
       print*, "Bin_Data options exceeded"
       STOP
    end if

  end subroutine Bin_Data

  subroutine OpenFile( Unum, Name, Contents, Column1, Column2 )
    implicit none
    integer, intent(in) :: Unum
    character(len=*), intent(in) :: Name, Contents, Column1, Column2
    character(len=25) :: filename
    filename = Name
    filename = FileNamer(filename)
    open (unit = Unum, file = "output/"//trim(filename)//"" ,status ='unknown' )

    write(Unum,*) "#This file contains the following data type for the ensemble: ", Trim(Contents)
    write(Unum,*) "#First column is: ", Trim(Column1)
    write(Unum,*) "#Second column is: ", Trim(Column2)
    write(Unum,*) "#Disorder Strength = ", DELTA
    write(Unum,*) "#Bond Cutoff = ", bond_cutoff
    write(Unum,*) "#Pruned bonds cutoff = ", prune_cutoff
    write(Unum,*) "#Fraction of n.n. sites in which at least one possible bond (of three) was pruned = ", &
         real(PrunedBonds)/real(n_d)
    write(Unum,*) "#Fraction of prunings that are useful = ", real(StrongestBondsPruned)/real(PrunedBonds)
    write(Unum,*) "#Hopping = ", hop
    write(Unum,*) "#Interaction strength = ", uSite
    write(Unum,*) "#Chemical Potential = ", ChemPot
    write(Unum,*) "#Dimensions = ", dim
    write(Unum,*) "#Number of systems = ", systemn

  end subroutine OpenFile

  !
  ! Prints data to file with unit number, Unum. Inputs: Unum = unit number for file, Form = format for the data, Bins array: xaxis, Data = Data.
  ! DoSMin + (DoSMax-DoSMin)*iii/real(bins)

  subroutine PrintData( Unum, Form, Min, Max, BinNum, Data_sp, Data_dp, Dropped )
    implicit none
    integer, intent(in) :: Unum, BinNum
    character(len=*), intent(in) :: Form
    real, intent(in), dimension(:), optional :: Data_sp
    real(dp), intent(in), dimension(:), optional :: Data_dp
    real, intent(in) :: Min, Max
    real, optional, intent(in) :: Dropped
    real :: BinWidth, sum1
    integer :: Loop1

    if ( Present(Data_dp) ) then
       BinWidth = (Max - Min)/real(BinNum)               ! Area of each bin (bins have equal width)
       do Loop1=1,BinNum
          write(Unum,(Form)) Min + ( Max - Min )*Loop1/real(BinNum) - BinWidth/2, Data_dp(Loop1)/( Sum(Data_dp)*BinWidth )
       end do
       sum1 = 0.0
       do Loop1=1,ClusterMax
          sum1 = sum1 + Data_dp(Loop1)/( Sum(Data_dp)*BinWidth )
       end do
       print*, "For W, U, B:", DELTA, uSite, bond_cutoff
       print*, "Total fraction of sites in 4-site clusters or less is: ", sum1
       print*, ""

    else if ( Present(Dropped) ) then
       BinWidth = (Max - Min)/real(BinNum)
       do Loop1=1,BinNum
          write(Unum,( Form)) Min + ( Max - Min )*Loop1/real(BinNum) - BinWidth/2, &
               Data_sp(Loop1)/( (Sum(Data_sp) + Dropped) * BinWidth )
       end do
    else

       BinWidth = (Max - Min)/real(BinNum)               ! Area of each bin (bins have equal width)
       print*, "BinWidth", BinWidth
       do Loop1=1,BinNum
          write(Unum,(Form)) Min + ( Max - Min )*Loop1/real(BinNum) - BinWidth/2, Data_sp(Loop1)/( Sum(Data_sp)*BinWidth )
       end do
       sum1 = 0.0
       do Loop1=1,ClusterMax
          sum1 = sum1 + Data_sp(Loop1)/( Sum(Data_sp)*BinWidth )
       end do
       print*, "For W, U, B:", DELTA, uSite, bond_cutoff
       print*, "Total fraction of sites in 4-site clusters or less is: ", sum1
       print*, ""
    end If

    Close(Unum)

  end subroutine PrintData

  subroutine resize_array(array, numRemove, Start)
    real, dimension(:), allocatable :: tmp_arr
    real, dimension(:), allocatable, intent(inout) :: array
    integer, intent(in) :: numRemove                           ! Number of elements to remove from 'array'
    integer, intent(in) :: Start                               ! The element in which to start removing the array
    integer i, j                                               ! Looping integer

    allocate(tmp_arr(size(array) - numRemove))

    tmp_arr(:) = 0

    j=1

    if ( (Start + numRemove) .le. size(array) ) then

       do i = 1, Start - 1

          tmp_arr(i) = array(i)
          j = j + 1

       end do

       do i = (Start + numRemove), Size(array)

          tmp_arr(j) = array(i)
          j = j + 1

       end do

    else if ( (Start + numRemove) .gt. size(array) ) then

       do i = (Start + numRemove - size(array)) , Start-1

          tmp_arr(j) = array(i)
          j = j + 1

       end do

    end if

    deallocate(array)
    allocate(array(size(tmp_arr)))

    array = tmp_arr

  end subroutine resize_array

  character(len=20) function str(k)                  ! function to change an integer to a string, used in FileNamer subroutine
     integer, intent(in) :: k

     write (str, *) k
     str = adjustl(str)
   end function str

   character(len=25) function FileNamer(Name)                                ! Increments filename labels Blah023.dat label:023
     character(len=25), intent(in) :: Name                                   ! Initial filename. Would be 'Blah' from above example
     integer num                                                             ! Keeps track of the label increment as this continues to check for name existence
     logical Exist                                                           ! Used to store if a filename exists

     Exist = .true.
     num = 0
     FileNamer = ""//trim(Name)//"000.text"                                  ! Takes Blah and puts it into the format 'Blah000.text'

     do while (Exist)                                                        ! Continue to change filename if the current one exists
        inquire( file = "output/"//trim(FileNamer)//"", exist = Exist )                           ! Checks the current folder (where this .f90 file is found) if the current filename exists
        if ( Exist ) then                                                    ! If the file name exists
           num = num + 1                                                     ! Increment the label

           if ( len(trim(str(num))) .eq. 1 ) then                            ! Labels can be from 000 to 999. To preserve filename length the leading zeros are required
              FileNamer = ""//trim(Name)//"00"//trim(str(num))//".text"      ! This if statement (and the one below) check the length of the label (1 has length 1, 23 has length 2, 450 has length 3)
           else if ( len(trim(str(num))) .eq. 2) then                        ! This determines the number of leading zeros to add to the filename label
              FileNamer = ""//trim(Name)//"0"//trim(str(num))//".text"
           else
              FileNamer = ""//trim(Name)//trim(str(num))//".text"
           end if

        else if ( .not. Exist ) then                                         ! If it does not exist. Note: Didn't increment 'num'
           if ( len(trim(str(num))) .eq. 1 ) then
              FileNamer = ""//trim(Name)//"00"//trim(str(num))//".text"
           else if ( len(trim(str(num))) .eq. 2) then
              FileNamer = ""//trim(Name)//"0"//trim(str(num))//".text"
           else
              FileNamer = ""//trim(Name)//trim(str(num))//".text"
           end if
           Exist = .false.
        else
           print*, "You belong in a museum. Error: FileNameErr"              ! Outputs error if something strange happens. Can't imagine what
        end if
     end do
   end function FileNamer

 end module Tools

max_stars_repo_name: djallum/AHMCode

max_issues_repo_name: djallum/AHMCode

max_forks_repo_name: djallum/AHMCode


text:
Davis Chinese Dance club is a brand new traditional and modern Chinese dance club for UC Davis students of all backgrounds interested in learning about Chinese culture through the art of Chinese Dance. NO EXPERIENCE IS NECESSARY so whether you have been performing Chinese Folk Dance since before you could walk, or can honestly swear that you do, in fact, have 2 left feet, everyone is welcome to come dance with us!

For more information and to stay updated with upcoming dance classes and performances, visit our Facebook page at http://facebook.com/groups/davischinesedance/. We hope to see you soon!


module infnan
  use shr_kind_mod, only: r8 => shr_kind_r8
  real(r8), parameter :: inf = 1.e19
  real(r8), parameter :: nan = 1.e21
  integer, parameter :: bigint = O'17777777777'
  real(r8), parameter :: uninit_r8 = inf
end module infnan