text:
      subroutine InterpFreq ( u, npts0, cu1, NN, nTotal, dt )
      real u(1)
      integer npts, m2, npts2, NN
      complex cu1(1)

      m2 = int( alog(float(npts0))/alog(2.) + 0.9999 )
      npts2 = 2**m2

c     PAD TO POWER OF 2 in the time domain
      do i=npts0+1,npts2
        u(i) = 0.
      enddo
      npts = npts2

c     FILL COMPLEX ARRAY
      do 10 i=1,npts
        cu1(i) = cmplx(u(i),0.0)
  10  continue

c     CALCULATE FORWARD FFT
      call cool ( -1., m2, cu1 )
      df = 1./(npts*dt)
c      do i=1,npts
c        write (60,'( f10.4, 2f12.4)') (i-1)*df, cu1(i)
c      enddo

c     Pad in the frequency domain
      iNyq = npts/2 + 1
      iNyq2 = NN * (npts/2) + 1
c      write (*,'( 2i10)') iNyq, iNyq2
      do i=iNyq+1,iNyq2
        cu1(i) = cmplx(0., 0.)
      enddo

c     Reset nyquist ot half its value (the other half will be added to the neg freq)
      cu1(iNyq) = cu1(iNyq)/2.

c     Load the negative frequencies
      nTotal = 2 * (iNyq2-1)
      do i=iNyq2+1,nTotal
        cu1(i) = conjg (cu1(nTotal+2-i))
      enddo

c     CALCULATE INVERSE FFT
      m3 = m2 + int( alog(float(NN))/alog(2.) + 0.5 )
      call cool ( 1., m3, cu1 )

c     Scale
      do i=1,nTotal
        u(i) = real(cu1(i)) /npts
      enddo

      return
      end

max_stars_repo_name: ZhangHCFJEA/bbp

max_issues_repo_name: ZhangHCFJEA/bbp

max_forks_repo_name: ZhangHCFJEA/bbp


      subroutine sq_greenampt

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    Predicts daily runoff given breakpoint precipitation and snow melt
!!    using the Green & Ampt technique

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    wst(:)%weat%ts(:)  |mm H2O        |precipitation for the time step during day
!!    swtrg(:)    |none          |rainfall event flag:
!!                               |  0: no rainfall event over midnight
!!                               |  1: rainfall event over midnight
!!    wfsh(:)     |mm            |average capillary suction at wetting front
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hhqday(:)   |mm H2O        |surface runoff generated each hour of day
!!                               |in HRU
!!    surfq(:)    |mm H2O        |surface runoff for the day in HRU
!!    swtrg(:)    |none          |rainfall event flag:
!!                               |  0: no rainfall event over midnight
!!                               |  1: rainfall event over midnight
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sum, Exp, Real, Mod

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use urban_data_module
      use climate_module
      use basin_module
      use hydrograph_module
      use hru_module, only : hru, swtrg, hhqday, ubnrunoff, hhsurfq, surfq, cnday, wfsh, ihru
      use soil_module
      use time_module

      implicit none

      integer :: j                               !none          |HRU number
      integer :: k                               !none          |counter
      integer :: kk                              !hour          |hour of day in which runoff is generated
      real :: adj_hc                             !mm/hr         |adjusted hydraulic conductivity
      real :: dthet                              !mm/mm         |initial moisture deficit
      real :: soilw                              !mm H2O        |amount of water in soil profile
      real :: psidt                              !mm            |suction at wetting front*initial moisture
                                                 !              |deficit
      real :: tst                                !mm H2O        |test value for cumulative infiltration
      real :: f1                                 !mm H2O        |test value for cumulative infiltration
      integer :: ulu
      real :: abstinit
      real, dimension (time%step+1) :: cuminf    !mm H2O        |cumulative infiltration for day
      real, dimension (time%step+1) :: cumr      !mm H2O        |cumulative rainfall for day
      real, dimension (time%step+1) :: excum     !mm H2O        |cumulative runoff for day
      real, dimension (time%step+1) :: exinc     !mm H2O        |runoff for time step
      real, dimension (time%step+1) :: rateinf   !mm/hr         |infiltration rate for time step
      real, dimension (time%step+1) :: rintns    !mm/hr         |rainfall intensity

      !! array location #1 is for last time step of prev day

       j = ihru
       ulu = hru(j)%luse%urb_lu

       !! reset values for day
       cumr = 0.
       cuminf = 0.
       excum = 0.
       exinc = 0.
       rateinf = 0.
       rintns = 0.

       !! calculate effective hydraulic conductivity
       adj_hc = (56.82 * soil(j)%phys(1)%k ** 0.286)                 &
                       / (1. + 0.051 * Exp(0.062 * cnday(j))) - 2.
       if (adj_hc <= 0.) adj_hc = 0.001

       dthet = 0.
       if (swtrg(j) == 1) then
         swtrg(j) = 0
         dthet = 0.001 * soil(j)%phys(1)%por * 0.95
       else
         if (soil(j)%sw >= soil(j)%sumfc) then
           soilw = 0.999 * soil(j)%sumfc
         else
           soilw = soil(j)%sw
         end if
         dthet = (1. - soilw / soil(j)%sumfc) *                  &
                                      soil(j)%phys(1)%por * 0.95
         rateinf(1) = 2000.
       end if

       psidt = 0.
       psidt = dthet * wfsh(j)

       k = 1
       rintns(1) = 60. * wst(iwst)%weat%ts(2) / Real(time%dtm)  !! urban 60./idt  NK Feb 4,08

       do k = 2, time%step+1
         !! calculate total amount of rainfall during day for time step
         cumr(k) = cumr(k-1) + wst(iwst)%weat%ts(k)
         !! and rainfall intensity for time step
         rintns(k) = 60. * wst(iwst)%weat%ts(k) / Real(time%dtm) !!urban 60./idt NK Feb 4,08

         !! if rainfall intensity is less than infiltration rate
         !! everything will infiltrate
         if (rateinf(k-1) >= rintns(k-1)) then
           cuminf(k) = cuminf(k-1) + rintns(k-1) *                       &
              Real(time%dtm) / 60. !!urban 60./idt NK Feb 4,08
           if (excum(k-1) > 0.) then
             excum(k) = excum(k-1)
             exinc(k) = 0.
           else
             excum(k) = 0.
             exinc(k) = 0.
           end if
          else
          !! if rainfall intensity is greater than infiltration rate
          !! find cumulative infiltration for time step by successive
          !! substitution
           tst = adj_hc * Real(time%dtm) / 60.  !!urban 60./idt NK Feb 4,08
           do
             f1 = 0.
             f1 = cuminf(k-1) + adj_hc * Real(time%dtm) / 60. +        &
                   psidt * Log((tst + psidt)/(cuminf(k-1) + psidt))
             if (Abs(f1 - tst) <= 0.001) then
               cuminf(k) = f1
               excum(k) = cumr(k) - cuminf(k)
               exinc(k) = excum(k) - excum(k-1)
               if (exinc(k) < 0.) exinc(k) = 0.
               hhqday(j,k-1) = exinc(k)
               exit
             else
               tst = 0.
               tst = f1
             end if
           end do
         end if

	   !! Urban Impervious cover
	   if (hru(j)%luse%urb_lu > 0) then
	      !runoff from pervious area
	      hhqday(j,k-1) = hhqday(j,k-1) * (1. - urbdb(ulu)%fcimp)

           !runoff from impervious area with initial abstraction
            ubnrunoff(k-1) = (wst(iwst)%weat%ts(k) - abstinit) * urbdb(ulu)%fcimp
            if ( ubnrunoff(k-1)<0)  ubnrunoff(k-1) = 0.
         end if

	   !! daily total runoff
	   hhsurfq(j,k-1) = hhqday(j,k-1) + ubnrunoff(k-1)
       surfq(j) = surfq(j) + hhsurfq(j,k-1)

         !! calculate new rate of infiltration
         rateinf(k) = adj_hc * (psidt / (cuminf(k) + 1.e-6) + 1.)

      end do

      if (Sum(wst(iwst)%weat%ts) > 12.) then
        swtrg(j) = 1
      end if

      return
 5000 format(//,"Excess rainfall calculation for day ",i3," of year ",   &
              i4," for sub-basin",i4,".",/)
 5001 format(t2,"Time",t9,"Incremental",t22,"Cumulative",t35,"Rainfall",   &
             t45,"Infiltration",t59,"Cumulative",t71,"Cumulative",t82,     &
             "Incremental",/,t2,"Step",t10,"Rainfall",t23,"Rainfall",      &
             t35,"Intensity",t49,"Rate",t58,"Infiltration",t73,"Runoff",   &
             t84,"Runoff",/,t12,"(mm)",t25,"(mm)",t36,"(mm/h)",t48,        &
             "(mm/h)",t62,"(mm)",t74,"(mm)",t85,"(mm)",/)
 5002 format(i5,t12,f5.2,t24,f6.2,t36,f6.2,t47,f7.2,t61,f6.2,t73,f6.2,     &
             t84,f6.2)
      end subroutine sq_greenampt


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

module multicharge_data_covrad
   use mctc_env, only : wp
   use mctc_io_convert, only : aatoau
   use mctc_io_symbols, only : to_number
   implicit none
   private

   public :: get_covalent_rad

   !> Covalent radii for DFT-D3 coordination number
   interface get_covalent_rad
      module procedure :: get_covalent_rad_num
      module procedure :: get_covalent_rad_sym
   end interface get_covalent_rad

   integer, parameter :: max_elem = 118

   !> Covalent radii (taken from Pyykko and Atsumi, Chem. Eur. J. 15, 2009,
   !  188-197), values for metals decreased by 10 %
   real(wp), parameter :: covalent_rad_2009(max_elem) = aatoau * [ &
      & 0.32_wp,0.46_wp, & ! H,He
      & 1.20_wp,0.94_wp,0.77_wp,0.75_wp,0.71_wp,0.63_wp,0.64_wp,0.67_wp, & ! Li-Ne
      & 1.40_wp,1.25_wp,1.13_wp,1.04_wp,1.10_wp,1.02_wp,0.99_wp,0.96_wp, & ! Na-Ar
      & 1.76_wp,1.54_wp, & ! K,Ca
      &                 1.33_wp,1.22_wp,1.21_wp,1.10_wp,1.07_wp, & ! Sc-
      &                 1.04_wp,1.00_wp,0.99_wp,1.01_wp,1.09_wp, & ! -Zn
      &                 1.12_wp,1.09_wp,1.15_wp,1.10_wp,1.14_wp,1.17_wp, & ! Ga-Kr
      & 1.89_wp,1.67_wp, & ! Rb,Sr
      &                 1.47_wp,1.39_wp,1.32_wp,1.24_wp,1.15_wp, & ! Y-
      &                 1.13_wp,1.13_wp,1.08_wp,1.15_wp,1.23_wp, & ! -Cd
      &                 1.28_wp,1.26_wp,1.26_wp,1.23_wp,1.32_wp,1.31_wp, & ! In-Xe
      & 2.09_wp,1.76_wp, & ! Cs,Ba
      &         1.62_wp,1.47_wp,1.58_wp,1.57_wp,1.56_wp,1.55_wp,1.51_wp, & ! La-Eu
      &         1.52_wp,1.51_wp,1.50_wp,1.49_wp,1.49_wp,1.48_wp,1.53_wp, & ! Gd-Yb
      &                 1.46_wp,1.37_wp,1.31_wp,1.23_wp,1.18_wp, & ! Lu-
      &                 1.16_wp,1.11_wp,1.12_wp,1.13_wp,1.32_wp, & ! -Hg
      &                 1.30_wp,1.30_wp,1.36_wp,1.31_wp,1.38_wp,1.42_wp, & ! Tl-Rn
      & 2.01_wp,1.81_wp, & ! Fr,Ra
      &      1.67_wp,1.58_wp,1.52_wp,1.53_wp,1.54_wp,1.55_wp,1.49_wp, & ! Ac-Am
      &      1.49_wp,1.51_wp,1.51_wp,1.48_wp,1.50_wp,1.56_wp,1.58_wp, & ! Cm-No
      &                 1.45_wp,1.41_wp,1.34_wp,1.29_wp,1.27_wp, & ! Lr-
      &                 1.21_wp,1.16_wp,1.15_wp,1.09_wp,1.22_wp, & ! -Cn
      &                 1.36_wp,1.43_wp,1.46_wp,1.58_wp,1.48_wp,1.57_wp ] ! Nh-Og

   !> D3 covalent radii used to construct the coordination number
   real(wp), parameter :: covalent_rad_d3(max_elem) = &
      & 4.0_wp / 3.0_wp * covalent_rad_2009

contains

!> Get covalent radius for a given element symbol
elemental function get_covalent_rad_sym(sym) result(rad)

   !> Element symbol
   character(len=*), intent(in) :: sym

   !> Covalent radius
   real(wp) :: rad

   rad = get_covalent_rad(to_number(sym))

end function get_covalent_rad_sym

!> Get covalent radius for a given atomic number
elemental function get_covalent_rad_num(num) result(rad)

   !> Atomic number
   integer, intent(in) :: num

   !> Covalent radius
   real(wp) :: rad

   if (num > 0 .and. num <= size(covalent_rad_d3)) then
      rad = covalent_rad_d3(num)
   else
      rad = 0.0_wp
   end if

end function get_covalent_rad_num

end module multicharge_data_covrad

max_stars_repo_name: loriab/multicharge

max_issues_repo_name: loriab/multicharge

max_forks_repo_name: loriab/multicharge


program main

	use params
      	use nestwrapper

	implicit none

	integer i
	double precision pi

	pi = 4d0*atan(1d0)

	!setting priors
	spriorran(1:sdim,1)=0d0
      	spriorran(1:sdim,2)=10d0*pi

      	!no parameters to wrap around
      	nest_pWrap=0

      	call nest_Sample
      	stop
end


text:
!! R504 object-name
!    is  name
!
! object-name is tested as part of an entity-decl (R503) that is part of
! a type-declaration-stmt (R501).

integer :: a

end

max_stars_repo_name: OpenFortranProject/ofp-sdf

max_issues_repo_name: OpenFortranProject/ofp-sdf

max_forks_repo_name: OpenFortranProject/ofp-sdf


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of ftheta in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: tlocal theta dtheta
!   with respect to varying inputs: tlocal
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!>    @brief calculates the fluid/ice partition function
!>    @param[in] tlocal = temperature
!>    @param[in] tliq = phase boundary temperature
!>    @param[in] wmushy =  scaling factor for "mushy" region = Tsolidus-tliqidus
!>    @param[in] ismpl local sample index
!>    @param[out] theta = value of partition function  (0<Theta<1)
!>    @param[out] dtheta = value of derivative of partition function with respect to temperature
!#>   returns the fluid/ice partition function theta and its derivative dtheta
!>    @details
!>calculates the fluid/ice partition function used for the \n
!>apparent heat capacity approach to phase change.\n
SUBROUTINE FTHETA_AD(tlocal, tlocal_ad, tliq, wmushy, theta, theta_ad, &
& dtheta, dtheta_ad, ismpl)
  use arrays

  USE ARRAYS_AD

  USE ICE
  IMPLICIT NONE
  INTEGER :: ismpl
  DOUBLE PRECISION :: tlocal, theta, dtheta, val, tliq, wmushy
  DOUBLE PRECISION :: tlocal_ad, theta_ad, dtheta_ad, val_ad
  INTRINSIC EXP
  DOUBLE PRECISION :: temporary_ad
  IF (tlocal .LT. tliq) THEN
    val = (tlocal-tliq)/wmushy
!         Theta=exp((-(T-Tf)/w)^2)
    theta = EXP(-(val*val))
!         dTheta=-2*(T-Tf)/w^2*Theta;
!       IF (theta.lt.liqmin) THEN
!         theta  =  liqmin
!         dtheta =  0.
!       END IF
    temporary_ad = -(2.d0*dtheta_ad/wmushy)
    theta_ad = theta_ad + val*temporary_ad
    val_ad = theta*temporary_ad - 2*val*EXP(-(val**2))*theta_ad
    tlocal_ad = tlocal_ad + val_ad/wmushy
  END IF
END SUBROUTINE FTHETA_AD


text:
http://www.thesainttwins.com/ Adrian Saint (real name Amir Ghasri) is a UC Davis student, CoHo employee, and wiki:WikiPedia:Mentalist Mentalist performer.  Saint has performed numerous shows around the Davis area.  In 2004 he appeared on MTV in a special about his techniques and life as a twin.  Saint astounded the Davis population in February of 2006 by http://www.californiaaggie.com/media/paper981/news/2006/02/08/CampusNews/Going.Mental1603769.shtml?norewrite&sourcedomainwww.californiaaggie.com predicting the results of the SuperBowl in a bet with The California Aggie, in which he would donate $1000 to charity if he was even a single point off.

Although he claims not to be a magician, he is teaching a class at the Experimental College called http://asucd.ucdavis.edu/experimentalcollege/index.cfm?pagesearch&coursesid2559 Magic for Effective Rapport that will get you laid.

Adrian Saint performed his last show in Davis at Historic City Hall and Bistro 33 on June 7, 2006. Fifty or so people were in attendence and some were quite astonished at some of his tricks. During the show he unveiled a new trick for him, a variant of Russian Roulette where there was a broken bottle inside of one of four paper bags, and he had a spectator tell him which bags to smash with his hand. Although from the side, it was obvious which bag had the bottle, so there was no risk to Saint, the audience was still pleased. It became especially funny when the spectator, who also knew which bag the bottle was in, told him to smash the bag that contained the bottle. Agitated, Saint kept asking Are you sure? until the spectator pointed to the correct bag.

 Superbowl Prediction Controversy
In http://www.californiaaggie.com/media/paper981/news/2006/02/03/Features/Mentalist.Has.Mind.In.Endzone.With.Super.Bowl.Bet1598509.shtml?norewrite&sourcedomainwww.californiaaggie.com his SuperBowl bet, Saint gave The California Aggie a sealed envelope containing his alleged prediction, and the Aggie agreed to keep it safe and locked in a vault.  On Tuesday Februrary 7th, Saint was given his sealed envelope during his presentation at Thompson Hall in front of an audience.  Saint opened the envelope, which contained a cassette tape, and placed the tape into an A/V setup.  He then played a recording of himself announcing the results of the SuperBowl.

What did Saint do?  One possiblity is that Saint had a CD in the A/V setup, instead played that one (which contained the known results), and either transfered the audio during the presentation to the old tape or just gave them an altered tape entirely. Tiny prophetic gnomes, nestled in Saints spleen, may have whispered to him the winning score weeks before the competing teams had even been chosen. Its also possible that Saint actually predicted the results.

The California Aggie followed up with another http://www.californiaaggie.com/media/paper981/news/2006/02/16/CampusNews/ThePower.To.Predict1616376.shtml?norewrite&sourcedomainwww.californiaaggie.com&page2 article about the Super Bowl prediction, this time interviewing outside sources that could give a thirdperson perspective on the issue.

The Sacramento Bee has since published an http://www.sacbee.com/content/news/story/14221880p15047464c.html article about Saints super bowl prediction, focusing on his publicity in The Aggie

Users/KarlMogel also addressed the Super Bowl prediction in a http://www.californiaaggie.com/media/paper981/news/2006/03/07/Opinion/Guest.Opinion.Reason.For.Skepticism1657657.shtml?norewrite&sourcedomainwww.californiaaggie.com&page1 guest opinion. Comments are encouraged on http://www.inoculatedmind.com/?p27 Karls Blog. Saint addressed some of Karls comments in this http://www.californiaaggie.com/media/paper981/news/2006/03/09/Opinion/Guest.Opinion.The.Mentalist.Strikes.Back1661490.shtml?norewrite&sourcedomainwww.californiaaggie.com   Aggie guest opinion two days later. It includes a few sports predictions and 5 predicted numbers for the March 18, 2006 Super Lotto. However, three of these predictions have already turned out wrong. None of the lotto numbers were predicted correctly, and Villanova was defeated in the NCAA mens basketball championship, and finally, the Detroit Pistons were beaten by Miami Heat in the NBA Championship.

On June 8, 2006, Saint was a guest on Karl Mogels radio show on KDRT, where Karl revealed http://www.inoculatedmind.com/?p49 how he thinks Saint did it. It turns out that the stereo he used matches a modifed stereo you can buy from magic stores that is designed to do this trick, called the http://www.magicauction.com/Mag_auc/mentalism.htm Impossible Cassette Prediction. (Scroll down to see it) After the show, Saint denied ever claiming that he really predicted the Super Bowl, implying that the Aggie overblew it. When Karl brought up the fact that he said I did predict the Super Bowl in his guest opinion, Saint said that you can use the word prediction in many different ways. This was off the air but recorded on tape.

20060210 00:53:15 nbsp This trick has been done numerous times by psychics, and was debunked by Penn & Teller over a year ago. If a prediction was indeed made, then it should have been revealed to someone before the Super Bowl. Because it was revealed more than a day after, all it takes is simple slightofhand.

Someone at The Aggie did suggest that Saint reveal the prediction right after the Super Bowl in the Aggie office, but he declined, saying he wanted to reveal it at the event. The prediction was given to them already sealed, preventing anyone from hearing it before the game. Users/KarlMogel

20060210 01:14:56 nbsp Is he claiming he has ESP, is psychic, etc. or is he doing this for entertainment purposes only? If the former, he should take the http://www.randi.org/research/faq.html JREF million dollar challenge, if the latter, give the guy some credit for stimulating critical thinking about how he could have achieved such a stunt.   Users/CraigBrozinsky

20060210 01:27:03 nbsp I am assuming his shows are for entertainment considering that we never see headlines such as Psychic wins Lottery!  I bought a lotto ticket using Saints predicted numbers and unfortunately lost my dollar. Well, I guess I paid a dollar for entertainment. Users/DussonYeung

20060210 08:50:39 nbsp Adrian does not claim to be a psychic. He is a mentalist which, as he points out, means he does get things wrong from time to time. Hes just usually right. If you really doubt what he can do, go see one of his shows the next time he does one. Users/EricFox
  Actually, Adrian Saint does claim to be a psychic, after doing some termredefining gymnastics in the FAQ of his website. Without saying yes, I consider myself a psychic, he says:
   Much like a sense that can be sharpened to compensate for the loss of another sense or the way human memory can be expanded and sharpened, ones psychic potential is always an unknown until it is revealed and explored. The ability to focus on that potential and to expand its boundaries is at the heart of a psychics extrasensory power.
 He also says that if by psychic, you mean talks to the dead, then he is not. He does call himself a Psychic Entertainer which is kind of like saying its Orange Drink instead of Orange Juice. Psychics also admit that they get things wrong from time to time. You misread/misheard him, as he used the gets things wrong from time to time to distinguish himself from a magician, not a psychic.
  Additionally, He claims on his website that he can read minds: The two primary things a mentalist can do is figure out what you are thinking (read your mind) and he can influence your decisions and actions. However, in the first Aggie article, he claims that he cant: I dont read minds
 He is no doubt an entertaining performer, but it is his claimed ability to predict the Super Bowl that is in question. Also, being there may bias your perception. Slightofhand works so well because you trust your eyes, and they are being fooled.  Users/KarlMogel KJM
   Update: Adrian Saint did not handle the tape, he activated the stereo with a remote control during the presentation. Although the stereo had only one tape deck, it did have a CD drive. According to Jeff Katz, who opened the box, the tape was rolling in the stereo. However, this does not rule out that a CD could have been playing on the speakers while the tape was playing. As pointed out above, it could indeed have been dubbing from the CD to the tape while playing on the speakers, resulting in both the appearance of the tape playing and the appearance of a prediction being made.  Users/KarlMogel KJM

20060210 09:45:51 nbsp Or he can just bother to reveal his prediction ahead of time. Users/JosephBleckman  I agree totally. The fact that it was not revealed before the event to anyone really makes calling it a prediction problematic.  Users/KarlMogel KJM

20060210 10:07:36 nbsp Isnt that photo on his website (c) The California Aggie? Users/ArlenAbraham  The photo is (c) Steven Nagareda, and Ghasri has permission to use it for ads and promotions. Users/KarlMogel KJM

20060210 16:30:12 nbsp Things arent always false if you cant explain them.  Theres always room for the unexplained.  Like why The Aggie got in the business of taking wagers. Users/BrentLaabs

20060213 17:14:46 nbsp The Aggie forgot to mention in the article that I never touched the tape, there was only one tape, I didnt switch it, and there was nothing in the CD player. I bought the tape for $1 from the student store and record it on my friends tape recorder. Someone at the show accused me of having my entire show, including the super bowl thing setup and staged. I offer a reward up to $25,000 if you can prove anything I do in my show is set up or staged. I just wanted to clear things up, since there been so much rumor and gossip about what I do. I dont care if you believe in what I do, but if you think everything I do is set up and staged, come see one of my shows, you probably walk out with a new perspective. And I dont have any powers!! Users/AdrianSaint

20060213 18:19:19 nbsp Ill take you up on it if you disprove the skeptics by announcing your predictions ahead of time for an upcoming sports game. Users/JosephBleckman

20060213 18:27:33 nbsp I did the super bowl prediction cuz my friend bet me, and I studied it for a year or so. My friend wants to predict the NCAA tournment, so for the fun of it, I just put my prediction in the aggie classifed section. You can bet on it if you want, but like I said I have no powers, I am a entertainer. I dont have to prove anything to anyone, but I just made that post to clear things up to show people everything I do is natural and logical, I have no powers or anything supernatural!  Users/AdrianSaint

20060213 18:30:49 nbsp Guys dont you see?! He cannot announce the outcome ahead of time because that would affect the outcome!  What part of Ashton Kutchers Butterfly Effect did you not understand? Users/MikeIvanov That they casted Ashton Kutcher. KJM :)

20060216 21:47:51 nbsp Predict the ASUCD election! Users/KrisFricke
  20060216 22:26:32 nbsp No thanks, I dont want to predict the ASUCD election cuz I predicted the fall ASUCD election. I done everything I wanted to do in Davis, with predicting the super bowl and election. I am in the process of moving on to bigger and better things. Working with my mentor on his TV special that is due out sometime next year and in process of possbilitiy appearing on Oprah and an A&E show in the upcoming year. But I do appreciate all the press that I got, from a $1 cassette tape that I bought from the student store. As they say in the mastercard commercials, it is priceless. Thanks to the press, my fee has gone up.  Users/AdrianSaint

20060216 22:34:38 nbsp The superbowl stunt was, well, a stunt. The real magic was getting all that free advertising from the aggie. Users/ArlenAbraham

20060216 22:37:56 nbsp I am in showbiz, and it wasnt just the aggie. I got free press from the Sac Bee, LA Times, Orange Country Register, (since I live in OC) and the Aggie.  Users/AdrianSaint
 Can you provide links to any of these stories? I tried ocregister.com, latimes.com, proquest and lexisnexis. Did they pick it up from Uwire?  Users/ArlenAbraham

Its entertainment; who cares how he did it.  The point is that you cant figure out how he did it, thats what makes it interesting. Plus, hes said in like 1000 Aggie articles that he uses probability, psychology, etc to do all this stuff, hence why he gets stuff wrong sometimes. Users/ChrisMay

20070907 23:18:38 nbsp What would blow my mind is if he could magically pull a personality out of his ass.  Users/JoshFernandez

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C
C	$Id: gqpmi.f,v 1.5 2008-07-27 00:21:00 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 GQPMI(ERRIND,INDEX)
C
C  INQUIRE POLYMARKER INDEX
C
      include 'gkscom.h'
C
      INTEGER ERRIND,INDEX
C
C  Check if GKS is in the proper state.
C
      CALL GZCKST(8,-1,ERRIND)
      IF (ERRIND.EQ.0) THEN
        INDEX = CPMI
      ELSE
        INDEX = -1
      ENDIF
C
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
! ***********************************************************************
!
!   Copyright (C) 2006, 2007, 2008, 2011  Bill Paxton, Frank Timmes
!
!   This file is part of MESA.
!
!   MESA is free software; you can redistribute it and/or modify
!   it under the terms of the GNU General Library Public License as published
!   by the Free Software Foundation; either version 2 of the License, or
!   (at your option) any later version.
!
!   MESA is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!   GNU Library General Public License for more details.
!
!   You should have received a copy of the GNU Library General Public License
!   along with this software; if not, write to the Free Software
!   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
! ***********************************************************************

      program test_net

      use mod_test_net, only: test

      implicit none

      call test(.false.)

      end program test_net

max_stars_repo_name: sailoridy/MAESTRO

max_issues_repo_name: sailoridy/MAESTRO

max_forks_repo_name: sailoridy/MAESTRO


text:
C ================================================================
      Subroutine loadMone(
C ================================================================
c group (M)
     &      nP,  MaxP,  nF,  MaxF,  nE,  MaxE,
     &      nPv, MaxPV, nFv, MaxFV, nEv, MaxEV,
     &      XYP, IPF, IPE, IPV, IFV, IEV, lbE,
     &      ParCrv, iFnc,
     &      fName)
C ==========================================================
C Routines read the input mesh from single file fName.sol.
C ==========================================================
C group (M)
C     Integer MaxP, MaxF, MaxE
      real  XYP(2, *)
      Integer IPE(3, *), IPF(4, *), IPV(*), IFV(*), IEV(*)
      Integer lbE(*)

      real  ParCrv(2, *)
      Integer iFnc(*)

      Character*(*) fName

c group (Local variables)
      Logical flagP, flagF, flagE, flagC, flagPV, flagFV, flagEV
      Character*30  fNameExt

C ==========================================================
      i = 1
      Do while( fName(i:i+3) .NE. '.ani')
         i = i + 1
      End do
      fNameExt = fName(1:i) // 'ani'

      Write(*,'(A,A)') 'Loading mesh ', fNameExt

      Open(10, file=fNameExt, status='OLD', ERR=1000)
      Read(10,*) flagP
      Read(10,*) flagF
      Read(10,*) flagE
      Read(10,*) flagC
      Read(10,*) flagPV
      Read(10,*) flagFV
      Read(10,*) flagEV

      Read(10,*)
      Read(10,*) nP
      If(nP.GT.MaxP) Call errMes(1003, 'loadMone',
     &                          'local parameter MaxP is small')
      Do n = 1, nP
         Read(10,*) (XYP(j, n), j = 1, 2)
      End do

c ... reading the boundary edges:
c     indices of the edge ends,                  1 2
c     number of respective line of curved edges  3
c     dummy integer                              4
c     label of the edge                          5
      Read(10,*)
      Read(10,*) nF
      If(nF.GT.MaxF) Call errMes(1004, 'loadMone',
     &                          'local parameter MaxF is small')
      Do n = 1, nF
         Read(10,*) (IPF(j, n), j = 1, 3), k, IPF(4, n)
      End do

      Read(10,*)
      Read(10,*) nE
      If(nE.GT.MaxE) Call errMes(1006, 'loadMone',
     &                          'local parameter MaxE is small')
      Do n = 1, nE
         Read(10,*) (IPE(j, n), j = 1, 3), lbE(n)
      End do

c ... reading parametrization of the curved boundary edges:
c     parametrization of the edge ends                      1 2
c     reference to the function of the parametrization      3
      Read(10,*)
      Read(10,*) nCrv
      If(nCrv.GT.MaxF) Call errMes(1004, 'loadMone',
     &                            'local parameter MaxF is small')
      Do n = 1, nCrv
         Read(10,*) (parCrv(j, n), j = 1, 2), iFnc(n)
      End do

c ... reading the fixed mesh points, faces and elements
      Read(10,*)
      Read(10,*) nPv
      If(nPv.GT.MaxPv) Call errMes(1008, 'loadM',
     &                            'local parameter MaxPV is small')
      Do n = 1, nPv
         Read(10,*) IPV(n)
      End do

      Read(10,*)
      Read(10,*) nFv
      If(nFv.GT.MaxFV) Call errMes(1008, 'loadM',
     &                            'local parameter MaxFV is small')
      Do n = 1, nFv
         Read(10,*) IFV(n)
      End do

      Read(10,*)
      Read(10,*) nEv
      If(nEv.GT.MaxEV) Call errMes(1008, 'loadM',
     &                            'local parameter MaxEV is small')
      Do n = 1, nEv
         Read(10,*) IEV(n)
      End do

      Close(10)

      Return

 1000 Continue
      Call errMes(4001, 'loadMone', 'Input file name is wrong ')
      Return
      End

C ==========================================================
      Subroutine loadS(nP, Sol, fName)
C ==========================================================
C Routine reads the solution from file fName.sol.
C ==========================================================
      real        Sol(*)
      Character*(*) fName

C group (Local variables)
      Character*30  fNameExt

C ==========================================================
      i = 1
      Do while( fName(i:i+3) .NE. '.sol')
         i = i + 1
      End do
      fNameExt = fName(1:i) // 'sol'

      Write(*,'(A,A)') 'Loading solution ', fNameExt

      Open(10, file=fNameExt, status='UNKNOWN')
      Read(10,*) nPw
      If(nPw.NE.nP) Call errMes(4003, 'loadS',
     &                   'mesh & data files are incompartible')

      Read(10,*)
      Do n = 1, nP
         Read(10,*) Sol(n)
      End do
      Close(10)

      Return
      End

C ==========================================================
      Subroutine loadM(
C ==========================================================
c group (M)
     &      nP,  MaxP,  nF,  MaxF,  nE,  MaxE,
     &      nPv, MaxPV, nFv, MaxFV, nEv, MaxEV,
     &      XYP, IPF, IPE, IPV, IFV, IEV, lbE,
     &      ParCrv, iFnc,
     &      fName)
C ==========================================================
C Routines read the input mesh from files fName.*
C
C *** Remark: no extension is required.
C ==========================================================
C group (M)
C     Integer MaxP, MaxF, MaxE
      real  XYP(2, *)
      Integer IPE(3, *), IPF(4, *), IPV(*), IFV(*), IEV(*)
      Integer lbE(*)

      real  ParCrv(2, *)
      Integer iFnc(*)

      Character*(*) fName

C group (Local variables)
      Character*30 fNameExt

C ==========================================================
      Write(*,'(A,A)') 'Loading mesh ', fName

c ... reading coordinates of the nodes
      fNameExt = fName // '.vrt'
      Open(10, file=fNameExt, status='OLD', ERR=1000)
      Read(10,*) nP
      If(nP.GT.MaxP) Call errMes(1003, 'loadM',
     &                          'local parameter MaxP is small')

      Read(10,*)
      Do n = 1, nP
         Read(10,*) (XYP(j, n), j = 1, 2)
      End do
      Close(10)

c ... reading the connectivity table
c     indices of the vertices,   1 2 3
c     label of the triangle      4
      fNameExt = fName // '.tri'
      Open(10, file=fNameExt, status='OLD', ERR=1000)
      Read(10,*) nE
      If(nE.GT.MaxE) Call errMes(1006, 'loadM',
     &                          'local parameter MaxE is small')

      Read(10,*)
      Do n = 1, nE
         Read(10,*) (IPE(j, n), j = 1, 3), lbE(n)
      End do
      Close(10)

c ... reading the boundary edges:
c     indices of the edge ends,                  1 2
c     number of respective line in fname//.crv,  3
c     dummy integer                              4
c     label of the edge                          5
      nF = 0
      fNameExt = fName // '.bnd'
      Open(10, file=fNameExt, status='OLD', ERR=100)
      Read(10,*) nF
      If(nF.GT.MaxF) Call errMes(1004, 'loadM',
     &                          'local parameter MaxF is small')

      Read(10,*)
      Do n = 1, nF
         Read(10,*) (IPF(j, n), j = 1, 3), k, IPF(4, n)
      End do
      Close(10)

c ... reading parametrization of the curved boundary edges:
c     parametrization of the edge ends                      1 2
c     reference to the function of the parametrization      3
 100  nCrv = 0
      fNameExt = fName // '.crv'
      Open(10, file=fNameExt, status='OLD', ERR=200)
      Read(10,*) nCrv

      Read(10,*)
      Do n = 1, nCrv
         Read(10,*) (parCrv(j, n), j = 1, 2), iFnc(n)
      End do
      Close(10)

c ... reading fixed (steady) nodes of the mesh
 200  nPv = 0
      fNameExt = fName // '.fix'
      Open(10, file=fNameExt, status='OLD', ERR=300)
      Read(10,*) nPv
      If(nPv.GT.MaxPv) Call errMes(1008, 'loadM',
     &                            'local parameter MaxPV is small')

      Read(10,*)
      Do n = 1, nPv
         Read(10,*) IPV(n)
      End do
      Close(10)

c ... reading fixed (steady) nodes of the mesh
 300  nFv = 0
      fNameExt = fName // '.ffv'
      Open(10, file=fNameExt, status='OLD', ERR=400)
      Read(10,*) nFv
      If(nFv.GT.MaxFV) Call errMes(1008, 'loadM',
     &                            'local parameter MaxFV is small')

      Read(10,*)
      Do n = 1, nFv
         Read(10,*) IFV(n)
      End do
      Close(10)

c ... reading fixed (steady) edges of the mesh
 400  nEv = 0
      fNameExt = fName // '.fev'
      Open(10, file=fNameExt, status='OLD', ERR=9000)
      Read(10,*) nEv
      If(nEv.GT.MaxEV) Call errMes(1008, 'loadM',
     &                            'local parameter MaxEV is small')

      Read(10,*)
      Do n = 1, nEv
         Read(10,*) IEV(n)
      End do
      Close(10)

 1000 Call errMes(4001, 'loadM', 'missing files')

 9000 Return
      End

C ================================================================
      Subroutine loadMgmv(
C ================================================================
c group (M)
     &      nP,  MaxP,  nF,  MaxF,  nE,  MaxE,
     &      nPv, MaxPV, nFv, MaxFV, nEv, MaxEV,
     &      XYP, IPF, IPE, IPV, IFV, IEV, lbE,
     &      ParCrv, iFnc,
     &      fName)
C ==========================================================
C Routines read the input mesh from single file fName.gmv.
C ==========================================================
C group (M)
C     Integer MaxP, MaxF, MaxE
      real  XYP(2, *)
      Integer IPE(3, *), IPF(4, *), IPV(*), IFV(*), IEV(*)
      Integer lbE(*)

      real  ParCrv(2, *)
      Integer iFnc(*)

      Character*(*) fName

c group (Local variables)
      Character*30  fNameExt, keyword

C ==========================================================
      fNameExt = fName // '.gmv'

      Write(*,'(A,A)') 'Loading mesh ', fNameExt

      Open(10, file=fNameExt, status='OLD', ERR=1000)
      Read(10,*)
      Read(10,*)
      Read(10,*)

      Read(10,*) keyword, nP
      If(nP.GT.MaxP) Call errMes(1003, 'loadMgmv',
     &                          'local parameter MaxP is small')
      Do n = 1, nP
         Read(10,*) (XYP(j, n), j = 1, 2)
      End do

c ... reading the boundary edges:
      nF = 0
      If(nF.GT.MaxF) Call errMes(1004, 'loadMgmv',
     &                          'local parameter MaxF is small')

c ... reading the elements:
      Read(10,*) keyword, nE
      If(nE.GT.MaxE) Call errMes(1006, 'loadMgmv',
     &                          'local parameter MaxE is small')
      Do n = 1, nE
         Read(10,*) keyword, m, (IPE(j, n), j = 1, 3)
      End do

c ... reading parametrization of the curved boundary edges:
      nCrv = 0
      If(nCrv.GT.MaxF) Call errMes(1004, 'loadMgmv',
     &                            'local parameter MaxF is small')

c ... reading the fixed mesh points, faces and elements
      nPv = 0
      nFv = 0
      nEv = 0

      Close(10)

      Return

 1000 Continue
      Call errMes(4001, 'loadMgmv', 'Input file name is wrong ')

      Return
      End


text:
      SUBROUTINE DSTRNG (PROMPT, RESP)

C  DSTRNG is used to get possibly multi-line character string
C  response from the operator.  Operator response is terminated
C  by a single "." on a line.  This termination line is not
C  included in the response.

C  Input parameters:
C    PROMPT      : prompt to be sent to operator.
C  Output parameters:
C    RESP        : answer from operator.

      INTEGER     ITRIM, NXTPOS

      CHARACTER   PROMPT*(*), RESP*(*), LINEIN*200

C  display prompt
      CALL IACMSG (PROMPT)
      NXTPOS = 1
      RESP = ' '

100   CONTINUE
C  get response string
      CALL IACANS (LINEIN)
      IF (LINEIN .EQ. '.') GOTO 200
C  append last line to non-blank stuff in RESP
      RESP (NXTPOS:) = LINEIN
      NXTPOS = ITRIM(RESP) + 2
C  check if at or near overflow ...
      IF (NXTPOS+5 .LT. LEN(RESP)) GOTO 100

200   CONTINUE

      END


text:
! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id: column_rand.f90 Wed Apr 11 20:26:43 CEST 2018 $

program column_rand

! Allows creation of input file for generating a set of randomly located
! observation stations with full column of obs for b-grid model. Should be
! nearly identical to similar thing for CAM, etc.

use      types_mod, only : r8, PI
use random_seq_mod, only : random_seq_type, init_random_seq, random_uniform
use  utilities_mod, only : get_unit
use   location_mod, only : VERTISSURFACE, VERTISLEVEL

implicit none

! version controlled file description for error handling, do not edit
character(len=*), parameter :: source   = "$URL: column_rand.f90 $"
character(len=*), parameter :: revision = "$Revision: Bonn $"
character(len=*), parameter :: revdate  = "$Date: Wed Apr 11 2018 $"

integer  :: level, num_cols, num_levs,num_dates, i,k, iunit
real(r8) :: lat, lon, t_err_var, uv_err_var, ps_err_var
real(r8) :: lat_data(10), lon_data(10), level_data(7)
integer  :: yyyy, daysinmonth(12), mm(60), dd_data(60), hh, mn, ss
character(len=1024) :: filename

data  lat_data/49.87, 49.95, 49.87, 49.95, 49.87, 49.95, 49.87, 49.95, 49.87, 49.95/
data  lon_data/ 5.48,  5.48,  5.55,  5.55,  5.62,  5.62,  5.69,  5.69,  5.75,  5.75/
data  level_data/10.0, 100.0, 200.0, 500., 1000.,3000.,5000./
data daysinmonth/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/
!data  dd_data/ 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 24, &
!              25, 26, 27, 28, 29, 30, 31,  1,  2,  3,  4,  5,  6,  7,  8/

!Pre Specified Date
yyyy = 2008
hh   = 0
mn   = 0
ss   = 0
mm(1)      = 6
dd_data(1) = 7
! Open an output file and write header info
iunit = get_unit()
open(unit = iunit, file = 'column_rand.out')

write(*, *) 'input the number of columns:10'
read(*, *) num_cols

write(*, *) 'input the number of model levels:7'
read(*, *) num_levs

write(*, *) 'input the number of dates:30'
read(*, *) num_dates

! Output the total number of obs
write(*, *) 'Max num is + 10 ', num_cols*(num_levs*num_dates)+10
write(iunit, *) num_cols*(num_levs*num_dates)+10     !CPS_write

! Get error variance for t
write(*, *) 'Input error VARIANCE for T obs'
read(*, *) t_err_var

! No values or qc
write(iunit, *) 0                          !CPS_write
write(iunit, *) 0                          !CPS_write

! Loop through each column
do k = 1, num_dates
! Allows day and month update for a year only
if (k .gt. 1) then
  dd_data(k) = dd_data(k-1) + 1
  if (dd_data(k) .le. daysinmonth(mm(k-1))) then
    mm(k) = mm(k-1)
  else
    dd_data(k) = 1    !start of new month
    mm(k) = mm(k-1) + 1
  end if
end if
do i = 1, num_cols
   ! Longitude
   lon = lon_data(i)

   ! Latitude
   lat = lat_data(i)

   ! Loop through each observation in the column
   do level = 1, num_levs

      write(iunit, *) 0                   !CPS_write
      ! Write out the t observation
      write(iunit, *) 5                   !CPS_write 'RADIOSONDE_TEMPERATURE'
      write(iunit, *) 3                   !CPS_write height
      write(iunit, *) level_data(level)   !CPS_write
      write(iunit, *) lon                 !CPS_write
      write(iunit, *) lat                 !CPS_write
      write(iunit, *) yyyy,mm(k),dd_data(k),hh,mn,ss        !CPS_write
      write(iunit, *) t_err_var           !CPS_write

   end do
end do
end do

write(iunit, *) -1                        !CPS_write
write(iunit, *) 'set_def.out'             !CPS_write
close(iunit)

!CPS added for export
do k = 1, num_dates
  iunit = get_unit()
  if (k .le. 9) then
    write (filename, "(A19,I1)") "column_export_out_0",k
  else
    write (filename, "(A18,I2)") "column_export_out_",k
  endif
  open(unit = iunit, file = trim(filename))
  write(iunit, *) 'set_def.out'             !CPS_write
  write(iunit, *) 1                         !CPS_write
  write(iunit, *) 1                         !CPS_write
  write(iunit, *) yyyy,mm(k),dd_data(k),hh,mn,ss        !CPS_write
  write(iunit, *) 0,0                         !CPS_write
  write(iunit, *) 'obs_seq.in'             !CPS_write
  close(iunit)
end do

end program column_rand

max_stars_repo_name: niklaswr/TSMP

max_issues_repo_name: niklaswr/TSMP

max_forks_repo_name: niklaswr/TSMP


text:
      SUBROUTINE grat1(a,x,r,p,q,eps)
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,eps,p,q,r,x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,
     +                 t,tol,w,z
C     ..
C     .. External Functions ..
      DOUBLE PRECISION erf,erfc1,gam1,rexp
      EXTERNAL erf,erfc1,gam1,rexp
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dlog,exp,sqrt
C     ..
C     .. Executable Statements ..
C-----------------------------------------------------------------------
C        EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
C                      P(A,X) AND Q(A,X)
C
C     IT IS ASSUMED THAT A .LE. 1.  EPS IS THE TOLERANCE TO BE USED.
C     THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A).
C-----------------------------------------------------------------------
      IF (a*x.EQ.0.0D0) GO TO 120
      IF (a.EQ.0.5D0) GO TO 100
      IF (x.LT.1.1D0) GO TO 10
      GO TO 60
C
C             TAYLOR SERIES FOR P(A,X)/X**A
C
   10 an = 3.0D0
      c = x
      sum = x/ (a+3.0D0)
      tol = 0.1D0*eps/ (a+1.0D0)
   20 an = an + 1.0D0
      c = -c* (x/an)
      t = c/ (a+an)
      sum = sum + t
      IF (abs(t).GT.tol) GO TO 20
      j = a*x* ((sum/6.0D0-0.5D0/ (a+2.0D0))*x+1.0D0/ (a+1.0D0))
C
      z = a*dlog(x)
      h = gam1(a)
      g = 1.0D0 + h
      IF (x.LT.0.25D0) GO TO 30
      IF (a.LT.x/2.59D0) GO TO 50
      GO TO 40

   30 IF (z.GT.-.13394D0) GO TO 50
C
   40 w = exp(z)
      p = w*g* (0.5D0+ (0.5D0-j))
      q = 0.5D0 + (0.5D0-p)
      RETURN
C
   50 l = rexp(z)
      w = 0.5D0 + (0.5D0+l)
      q = (w*j-l)*g - h
      IF (q.LT.0.0D0) GO TO 90
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
C              CONTINUED FRACTION EXPANSION
C
   60 a2nm1 = 1.0D0
      a2n = 1.0D0
      b2nm1 = x
      b2n = x + (1.0D0-a)
      c = 1.0D0
   70 a2nm1 = x*a2n + c*a2nm1
      b2nm1 = x*b2n + c*b2nm1
      am0 = a2nm1/b2nm1
      c = c + 1.0D0
      cma = c - a
      a2n = a2nm1 + cma*a2n
      b2n = b2nm1 + cma*b2n
      an0 = a2n/b2n
      IF (abs(an0-am0).GE.eps*an0) GO TO 70
      q = r*an0
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
C                SPECIAL CASES
C
   80 p = 0.0D0
      q = 1.0D0
      RETURN
C
   90 p = 1.0D0
      q = 0.0D0
      RETURN
C
  100 IF (x.GE.0.25D0) GO TO 110
      p = erf(sqrt(x))
      q = 0.5D0 + (0.5D0-p)
      RETURN

  110 q = erfc1(0,sqrt(x))
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
  120 IF (x.LE.a) GO TO 80
      GO TO 90

      END

max_stars_repo_name: Ennosigaeon/scipy

max_issues_repo_name: Ennosigaeon/scipy

max_forks_repo_name: Ennosigaeon/scipy


text:
module Mod_sldup_calculateAU
  use typre
  implicit none

  contains

  subroutine getAU_U(nd,gradp,divstr,AU)
      integer(ip),          intent(in)    :: nd
      real(rp),             intent(in)    :: gradp(nd),divstr(nd)
      real(rp),             intent(inout) :: AU(nd)

      !A(U)
      AU = - gradp - divstr

  end subroutine

  subroutine getAU_U_dyn(nd,densi,accel,gradp,divstr,AU)
      integer(ip),          intent(in)    :: nd
      real(rp),             intent(in)    :: gradp(nd),divstr(nd),accel(nd),densi
      real(rp),             intent(inout) :: AU(nd)

      !A(U)
      AU = densi*accel - gradp - divstr

  end subroutine

  subroutine getAU_P(nd,mu,lam,J,b,gpress,AU)
      integer(ip),          intent(in)    :: nd
      real(rp),             intent(in)    :: mu,lam,J,b(nd,nd)
      real(rp),             intent(in)    :: gpress(1)
      real(rp),             intent(inout) :: AU
      real(rp)                            :: b_ii

      call trace(nd,b,b_ii)
      !A(U):
      AU = (J/lam)*gpress(1)-(mu/lam)*((b_ii/nd)-1.0_rp)
      AU = AU - log(J)

  end subroutine

  subroutine getAU_P_OSGS(nd,mu,lam,J,b,gpress,AU)
      integer(ip),          intent(in)    :: nd
      real(rp),             intent(in)    :: mu,lam,J,b(nd,nd)
      real(rp),             intent(in)    :: gpress(1)
      real(rp),             intent(inout) :: AU
      real(rp)                            :: b_ii

      call trace(nd,b,b_ii)
      !A(U):
      AU = -(mu/lam)*((b_ii/nd)-1.0_rp)
      AU = AU - log(J)

  end subroutine

  end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
!***********************************************************************
!
!    Copyright (c) 2020, Lawrence Livermore National Security, LLC.
!                        Produced at the Lawrence Livermore National
!                        Laboratory.
!                        Lead developer: Nicolas Schunck, schunck1@llnl.gov
!    HFODD
!    -----
!      LLNL-CODE-710577 All rights reserved.
!      LLNL-CODE-470611 All rights reserved.
!
!      Copyright 2017, N. Schunck, J. Dobaczewski, W. Satula, P. Baczyk,
!                      J. Dudek, Y. Gao, M. Konieczka, K. Sato, Y. Shi,
!                      X.B. Wang, and T.R. Werner
!      Copyright 2012, N. Schunck, J. Dobaczewski, J. McDonnell,
!                      W. Satula, J.A. Sheikh, A. Staszczak,
!                      M. Stoitsov, P. Toivanen
!      Copyright 2009, J. Dobaczewski, W. Satula, B.G. Carlsson, J. Engel,
!                      P. Olbratowski, P. Powalowski, M. Sadziak,
!                      J. Sarich, N. Schunck, A. Staszczak, M. Stoitsov,
!                      M. Zalewski, H. Zdunczuk
!      Copyright 2004, 2005, J. Dobaczewski, P. Olbratowski
!      Copyright 1997, 2000, J. Dobaczewski, J. Dudek
!
!    HFBTHO
!    -----
!      LLNL-CODE-728299 All rights reserved.
!      LLNL-CODE-573953 All rights reserved.
!
!      Copyright 2017, R. Navarro Perez, N. Schunck, R. Lasseri, C. Zhang, J. Sarich
!      Copyright 2012, M.V. Stoitsov, N. Schunck, M. Kortelainen, H.A. Nam,
!                      N. Michel, J. Sarich, S. Wild
!      Copyright 2005, M.V. Stoitsov, J. Dobaczewski, W. Nazarewicz, P.Ring
!
!
!    This file is part of DFTNESS.
!
!    DFTNESS is free software: you can redistribute it and/or modify it
!    under the terms of the GNU General Public License as published by
!    the Free Software Foundation, either version 3 of the License, or
!    (at your option) any later version.
!
!    DFTNESS is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!    GNU General Public License for more details.
!
!    You should have received a copy of the GNU General Public License
!    along with DFTNESS. If not, see <http://www.gnu.org/licenses/>.
!
!    OUR NOTICE AND TERMS AND CONDITIONS OF THE GNU GENERAL PUBLIC
!    LICENSE
!
!    Our Preamble Notice
!
!      A. This notice is required to be provided under our contract
!         with the U.S. Department of Energy (DOE). This work was
!         produced at the Lawrence Livermore National Laboratory under
!         Contract No. DE-AC52-07NA27344 with the DOE.
!      B. Neither the United States Government nor Lawrence Livermore
!         National Security, LLC nor any of their employees, makes any
!         warranty, express or implied, or assumes any liability or
!         responsibility for the accuracy, completeness, or usefulness
!         of any information, apparatus, product, or process disclosed,
!         or represents that its use would not infringe privately-owned
!         rights.
!      C. Also, reference herein to any specific commercial products,
!         process, or services by trade name, trademark, manufacturer
!         or otherwise does not necessarily constitute or imply its
!         endorsement, recommendation, or favoring by the United States
!         Government or Lawrence Livermore National Security, LLC. The
!         views and opinions of authors expressed herein do not
!         necessarily state or reflect those of the United States
!         Government or Lawrence Livermore National Security, LLC, and
!         shall not be used for advertising or product endorsement
!         purposes.
!
!    The precise terms and conditions for copying, distribution and
!    modification are contained in the file COPYING.
!
!***********************************************************************

 !-------------------------------------------------------------------
 !
 !                  TYPES, CONSTANTS
 !
 !-------------------------------------------------------------------
Module hfodd_types

   Implicit None

   Integer, Parameter, Public :: ipr=Kind(1)     !< default integer precision
   Integer, Parameter, Public :: pr =Kind(1.0d0) !< default real precision

#if(USE_MPI==0)
   Integer, Parameter, Public :: NFIPRI = 6
#else
   Integer, Parameter, Public :: NFIPRI = 88
#endif

   Real(pr), Parameter, Public :: PI = 4.0_pr*Atan(1.0_pr) !< Pi
   Real(pr), Parameter, Public :: DEGRAD = 180.0_pr/PI     !< To convert from radians to degrees
   Real(pr), Parameter, Public :: SQR4PI = 4.0_pr*Sqrt(Atan(1.0_pr)) !< \f$ \sqrt{4\pi} \f$

   Complex(pr), Parameter, Public :: C_ZERO=Cmplx( 0.0_pr,0.0_pr)
   Complex(pr), Parameter, Public :: C_UNIT=Cmplx( 1.0_pr,0.0_pr)
   Complex(pr), Parameter, Public :: UNIT_I=Cmplx( 0.0_pr,1.0_pr)
   Complex(pr), Parameter, Public :: C_MINU=Cmplx(-1.0_pr,0.0_pr)

   ! Physical constants
   Real(pr), Parameter, Public :: H_BARC=197.32891_pr, XMASSP=938.27231_pr, XMASSN=938.90590_pr
   Real(pr), Parameter, Public :: HBCOE2=137.03602_pr

   ! (Possibly) convenient derived types
   Type nucleus
      Integer(ipr), Public :: IZ_FIX
      Integer(ipr), Public :: IN_FIX
      Real(pr), Public :: XZ_FIX
      Real(pr), Public :: XN_FIX
   End Type nucleus

   Type skyrme_contributions
      Real(pr) :: ERHO_T
      Real(pr) :: ERHO_S
      Real(pr) :: ERHODT
      Real(pr) :: ERHODS
      Real(pr) :: ELPR_T
      Real(pr) :: ELPR_S
      Real(pr) :: ETAU_T
      Real(pr) :: ETAU_S
      Real(pr) :: ESCU_T
      Real(pr) :: ESCU_S
      Real(pr) :: EDIV_T
      Real(pr) :: EDIV_S
      Real(pr) :: ESPI_T
      Real(pr) :: ESPI_S
      Real(pr) :: ESPIDT
      Real(pr) :: ESPIDS
      Real(pr) :: ELPS_T
      Real(pr) :: ELPS_S
      Real(pr) :: ECUR_T
      Real(pr) :: ECUR_S
      Real(pr) :: EKIS_T
      Real(pr) :: EKIS_S
      Real(pr) :: EROT_T
      Real(pr) :: EROT_S
   End Type skyrme_contributions

   Type energies
      Real(pr) :: EKIN_N
      Real(pr) :: EKIN_P
      Real(pr) :: EKIN_T
      Real(pr) :: EPOT_N
      Real(pr) :: EPOT_P
      Real(pr) :: EPOT_T
      Real(pr) :: ESUM_N
      Real(pr) :: ESUM_P
      Real(pr) :: ESUM_T
      Real(pr) :: EPAI_N
      Real(pr) :: EPAI_P
      Real(pr) :: EPAI_T
      Real(pr) :: EREA_N
      Real(pr) :: EREA_P
      Real(pr) :: EREA_T
      Real(pr) :: ELIP_N
      Real(pr) :: ELIP_P
      Real(pr) :: ELIP_T
      Real(pr) :: ECOULD
      Real(pr) :: ECOULE
      Real(pr) :: ECOULT
      Real(pr) :: ECOULS
      Real(pr) :: ECOULV
      Real(pr) :: EMULCO
      Real(pr) :: EMUSLO
      Real(pr) :: EMUREA
      Real(pr) :: ESIFCO
      Real(pr) :: ESISLO
      Real(pr) :: ESIREA
      Real(pr) :: ESPICO
      Real(pr) :: ESPSLO
      Real(pr) :: ESPREA
      Real(pr) :: ENREAR
      Real(pr) :: ECORCM
      Real(pr) :: ECOR_R
      Real(pr) :: EEVEW0
      Real(pr) :: EODDW0
      Real(pr) :: ENE_W0
      Real(pr) :: ENEVEN
      Real(pr) :: ENEODD
      Real(pr) :: ENESKY
      Real(pr) :: ESTABN
      Real(pr) :: ETOTSP
      Real(pr) :: ETOTFU
   End Type energies

Contains

End Module hfodd_types

max_stars_repo_name: HPCL/nuclei-bench

max_issues_repo_name: HPCL/nuclei-bench

max_forks_repo_name: HPCL/nuclei-bench


text:
!    NetworkMaker software (General Node Model)
!    Computational model to simulate morphogenetic processes in living organs and tissues.
!    Copyright (C) 2014 Roland Zimm & Isaac Salazar-Ciudad

!    This program is free software: you can redistribute it and/or modify
!    it under the terms of the GNU General Public License as published by
!    the Free Software Foundation, either version 3 of the License, or
!    any later version.

!    This program is distributed in the hope that it will be useful,
!    but WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!    GNU General Public License for more details.

!    You should have received a copy of the GNU General Public License
!    along with this program.  If not, see <http://www.gnu.org/licenses/>.

module basics

use gtk
use gdk
use gtk_hl
use iso_c_binding, only: c_ptr, c_char, c_int

implicit none

type(c_ptr) :: window

end module basics

module functions

use basics

contains

subroutine my_destroy2(widget, gdata) bind(c)

  type(c_ptr), value :: widget, gdata
  integer(kind=c_int) :: ok

  call gtk_widget_destroy(window)
  call gtk_main_quit ()

end subroutine my_destroy2

function choose_input (widget, gdata ) result(ret)  bind(c)

  use iso_c_binding, only: c_ptr, c_int
  use basics

  !use Input_handlers
  implicit none

  type(c_ptr) :: base, jb, junk
  type(c_ptr), value :: widget, gdata
  integer(c_int)    :: ret

  character(len=30), dimension(3) :: filters
  character(len=30), dimension(3) :: filtnames
  character(len=240) :: filename3
  filters(3) = "text/plain"
  filters(2) = "*.f90"
  filters(1) = "*"
  filtnames(3) = "Text files"
  filtnames(2) = "Fortran code"
  filtnames(1) = "All files"

  ! Initialize GTK
  call gtk_init()

  ! Create a window and a column boxi

  window = hl_gtk_window_new("Choose an input file from this or a child folder!"//c_null_char, &
       & destroy=c_funloc(my_destroy2))

  base = hl_gtk_box_new()
  call gtk_container_add(window, base)
  jb = hl_gtk_box_new(horizontal=TRUE, homogeneous=TRUE)
  call hl_gtk_box_pack(base, jb)
  junk = hl_gtk_file_chooser_button_new(title="Choose an input file"//c_null_char, &
       & filter=filters, filter_name=filtnames, file_set=c_funloc(do_open))
  !junk = hl_gtk_button_new("CHOOSE (FROM THE SAME FOLDER)!"//c_null_char, clicked=c_funloc(open_file))
  call hl_gtk_box_pack(jb, junk)
 ! junk = hl_gtk_button_new("Print choices"//c_null_char, clicked=c_funloc(display_file))
 ! call hl_gtk_box_pack(base, junk)
 ! junk = hl_gtk_button_new("Display choices"//c_null_char, clicked=c_funloc(read_data_again_ini))
 ! call hl_gtk_box_pack(base, junk)
  junk = hl_gtk_button_new("-----------------Quit-----------------"//c_null_char, clicked=c_funloc(my_destroy2))
  call hl_gtk_box_pack(base, junk)

  call gtk_widget_show_all(window)

  call gtk_main()

  !filename3=filename

end function choose_input

subroutine do_open(widget, gdata) bind(c)

  use gtk_hl
  use gtk_os_dependent
  use basics
  use iso_c_binding, only: c_ptr, c_int

    type(c_ptr), value :: widget, gdata

    type(c_ptr) :: c_string
    character(len=200) :: inln
    integer :: ios
    integer :: idxs
    character(len=120) :: filename, filenamen=''
    character(len=140) :: input

    call gtk_window_set_title(window, "Choose an input file"//c_null_char)
    c_string = gtk_file_chooser_get_filename(widget)
    call convert_c_string(c_string, filenamen)
    call g_free(c_string)

    idxs = index(filenamen, '/', .true.)+1
    call gtk_window_set_title(window, trim(filenamen(idxs:))//c_null_char)
    print*, filenamen
    filename=trim(filenamen)

    print*, "FILENAME", filename
    input="cp "//trim(filename)//" newchoice.dat" ! saves the file as a local "newchoice.dat"
    call system(input)
    input="./NetworkMaker newchoice.dat" ! This launches the interface directly
    call system(input)

end subroutine do_open

subroutine open_file(widget, gdata) bind(c)

  use g
  use gtk_hl
  use gtk_hl_container
  use gtk_hl_entry
  use gtk_hl_button
  use gtk_hl_chooser
  use gdk_events
  use gdk
  use gtk
  use gtk_os_dependent
  use gtk_sup
  type(c_ptr), value :: widget, gdata
  type(c_ptr) :: window

  integer(kind=c_int) :: isel
  character(len=240), dimension(:), allocatable :: chfile
  character(len=240) :: filename
  character(len=30), dimension(4) :: filters
  character(len=30), dimension(4) :: filtnames
print*, "EINS"
  filters(1) = "*"
  filters(2) = "*.txt,*.lis"
  filters(3) = "*.f90"
  filters(4) = "*.dat,*.log"
  filtnames(1) = "All files"
  filtnames(2) = "Text files"
  filtnames(3) = "Fortran code"
  filtnames(4) = "Output files"
print*, "EINSKOMMAFÜNF"
  isel = hl_gtk_file_chooser_show(chfile, create=FALSE,&
         & title="Select input file"//c_null_char, filter=filters, &
         & filter_name=filtnames, wsize=(/ 600_c_int, 400_c_int /), &
         & edit_filters=TRUE, &
         & parent=window, all=TRUE)
print*, "ZWEI"
  if (isel == FALSE) return   ! No selection made
print*, "DREI"
  filename = chfile(1)
  deallocate(chfile)
print*, "VIER"

  !!!call gtk_widget_destroy(window)

end subroutine open_file

function Start_program (widget, gdata ) result(ret)  bind(c)

  use iso_c_binding, only: c_ptr, c_int

  implicit none

  type(c_ptr), value :: widget, gdata
  integer(c_int)    :: ret
  character*140 :: dir
  character*150 :: ddir

  call getarg(1,dir)

  if(len(dir).lt.1)then
    ddir="./NetworkMaker "//trim(dir)
  else
    ddir="./NetworkMaker "
  endif
  call system(ddir)

end function Start_program

function Start_program_0 (widget, gdata ) result(ret)  bind(c)

  use iso_c_binding, only: c_ptr, c_int

  implicit none

  type(c_ptr), value :: widget, gdata
  integer(c_int)    :: ret
  character*140 :: dir
  character*150 :: ddir

  call getarg(1,dir)
  ddir="./NetworkMaker "
  call system(ddir)

end function Start_program_0

function End_program (widget, gdata ) result(ret)  bind(c)

  use iso_c_binding, only: c_ptr, c_int

  implicit none

  type(c_ptr), value :: widget, gdata
  integer(c_int)    :: ret

  call gtk_main_quit()

end function End_program

end module functions

program grn_interface

  use iso_c_binding, only: c_ptr, c_char, c_int
  use gtk
  use gdk, only: gdk_cairo_create, gdk_cairo_set_source_pixbuf

  use gdk_pixbuf, only: gdk_pixbuf_get_n_channels, gdk_pixbuf_get_pixels, gdk_pix&
  &buf_get_rowstride, gdk_pixbuf_new

  use functions
  use basics

  !use event_handlers
  !use global_widgets
  !use on_display_handlers
  !use io
  !use basic_handlers
  !use rb_handlers !>>Miquel8-10-14

  implicit none

  type(c_ptr) :: table, box, my_window, button1, button2, button3, button4, my_pixbuf, base, junk, jb
  integer :: width_e, height_e
  real*8 :: newval
  real*4 :: xal, yal
  real*8 :: parval
  character(kind=c_char), dimension(:), pointer :: pixel
  integer(kind=c_int) :: nch, rowstride, pixwidth_e, pixheight_e
  logical :: computing = .false.
  character(LEN=80) :: string
  character*140 :: di
  character*150 :: ddi

  integer(c_int)    :: ret

  character(len=30), dimension(3) :: filters
  character(len=30), dimension(3) :: filtnames
  character(len=240) :: filename3
  filters(3) = "text/plain"
  filters(2) = "*.f90"
  filters(1) = "*"
  filtnames(3) = "Text files"
  filtnames(2) = "Fortran code"
  filtnames(1) = "All files"

  !type(c_ptr) :: labeltc

  call getarg(1,di)
  ddi="./NetworkMaker "//trim(di)
  print*, "STARTTTTTTTTTTT", di, len(trim(di))

  if(len(trim(di))>1) call system(ddi)
    if(len(trim(di))==1)then
      ddi="./NetworkMaker void"
      call system(ddi)
    end if

  call gtk_init ()
  ! Properties of the main_1 window :
  width_e = 300
  height_e = 150
  ! Define all widgets
  my_window = gtk_window_new (GTK_WINDOW_TOPLEVEL)
  button1 = gtk_label_new (" Choose a new input file "//c_null_char)
  button2 = gtk_button_new_with_mnemonic ("*** START ***"//c_null_char)
  button3 = gtk_button_new_with_mnemonic ("Quit"//c_null_char)
  button4 = gtk_button_new_with_mnemonic ("Create a new GRN"//c_null_char)
  table = gtk_table_new (2_c_int, 2_c_int, TRUE)
  box = gtk_hbox_new (FALSE, 2_c_int)

  call gtk_window_set_default_size(my_window, width_e, height_e)
  call gtk_window_set_title(my_window, "Launch NetworkMaker"//c_null_char)
  call g_signal_connect (button2, "clicked"//c_null_char, c_funloc(Start_program))
  call g_signal_connect (button4, "clicked"//c_null_char, c_funloc(Start_program_0))
  call g_signal_connect (button3, "clicked"//c_null_char, c_funloc(End_program))

  call gtk_table_attach_defaults(table, button1, 0_c_int, 2_c_int, 0_c_int, 1_c_int)  !>>Miquel8-10-14
  call gtk_table_attach_defaults(table, button2, 0_c_int, 4_c_int, 2_c_int, 4_c_int) !
  call gtk_table_attach_defaults(table, button3, 0_c_int, 4_c_int, 4_c_int, 5_c_int)
  call gtk_table_attach_defaults(table, button4, 0_c_int, 4_c_int, 1_c_int, 2_c_int)

  junk = hl_gtk_file_chooser_button_new(title="Choose an input file"//c_null_char, &
       & filter=filters, filter_name=filtnames, file_set=c_funloc(do_open))

  call gtk_table_attach_defaults(table, junk, 2_c_int, 4_c_int, 0_c_int, 1_c_int)
! show all
  call gtk_box_pack_start (box, table, FALSE, FALSE, 0_c_int)
  call gtk_container_add (my_window, box)
  call gtk_window_set_mnemonics_visible (my_window, TRUE)

  call gtk_widget_show_all (my_window)

  call gtk_main ()

end program grn_interface

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!gfortran -w general.mod.f90 io.mod.f90 genetic.mod.f90 grn_editor_whole.f90 -o grnee.e `pkg-config --cflags --libs /home/rolazimm/Desktop/gtk-fortran/gtk-fortran-master/build/src/gtk-2-fortran.pc gtk+-2.0`

max_stars_repo_name: isalazarciudad/EmbryoMaker

max_issues_repo_name: sebjameswml/EmbryoMaker

max_forks_repo_name: sebjameswml/EmbryoMaker


text:
module ewald
  implicit none
  double precision, parameter :: qe=1.602176565d-19, eps0=8.854187817D-12, pi=acos(-1.D0), sqrtpi=sqrt(pi), pi2=pi**2,&
      twopi=2.d0*pi, qfact=1389.3545783908448 !kJ/mol qfact=(qe**2)/(4.D0*pi*eps0*1D-10)!    ! in Joules
  complex, parameter :: twopii=cmplx(0.d0,twopi)
  double precision, parameter :: rcut = 10.d0
  integer, parameter :: kmax=5, nkmax=27
  double precision :: alpha, alpha2, pi2Ialpha2

  public

contains
  subroutine ewald_init(len)
    implicit none
    double precision, intent(in) :: len
    alpha=5.6d0/len
    alpha2=alpha**2
    pi2Ialpha2=pi2/alpha2
  end subroutine

  subroutine ewald_energy (N,len,q,x,y,z,Uewald)
    implicit none
    integer, intent(in) :: N ! number of sites
    double precision, intent(in) :: len
    double precision, intent(out) :: Uewald
    double precision, intent(in) :: q(3*N), x(3*N), y(3*N), z(3*N)
    double precision :: Ereal, Eself, r, k2lmn, Efourier, Eintra, symfac
    complex :: Efourier_part2
    integer :: i,j,l,m,o
    ! open(46,file="/home/levesque/Recherche/src/libewald/spce_sample_config_periodic1.txt")
    ! read(46,*)
    ! read(46,*)
    ! do i=1,3*N
    !   read(46,*)j,x(i),y(i),z(i)
    ! end do
    ! close(46)
    Ereal=0.d0
    Eintra=0.d0
    do i=1,3*N-1
      do j=i+1,3*N
        r=rij(i,j)
        if(moleculeofsite(i)==moleculeofsite(j)) then
          Eintra = Eintra -q(j)*q(i)*erf(alpha*r)/r
        else
          if(r>rcut) cycle
          Ereal = Ereal +q(j)*q(i)*erfc(alpha*r)/r
        end if
      end do
    end do
    Ereal= Ereal*qfact
    Eintra= Eintra*qfact
    Eself = -alpha/sqrtpi *sum(q**2) *qfact

    Efourier = 0.d0
    do l=0,kmax
      select case(l); case(0); symfac = 1.d0; case default; symfac = 2.d0; end select
      do m=-kmax,kmax
        do o=-kmax,kmax
          if(l==0 .and. m==0 .and. o==0) cycle ! E(k=0)=0
          if(l**2+m**2+o**2 >= nkmax) cycle
          k2lmn = k2(l,m,o)
          Efourier = Efourier + symfac*Exp(-k2lmn*pi2Ialpha2)/k2lmn *abs(sum(  q*Exp(twopii/len*(l*x+m*y+o*z))  ))**2
        end do
      end do
    end do
    Efourier = Efourier *1.d0/(twopi*len**3) *qfact

    Uewald = Ereal + Eintra + Eself + Efourier

  contains

    pure function rij(i,j)
      implicit none
      double precision :: rij
      integer, intent(in) :: i,j
      double precision :: dx, dy, dz
      dx = abs( x(i)-x(j) )
      if(dx>len/2.) dx=len-dx
      dy = abs( y(i)-y(j) )
      if(dy>len/2.) dy=len-dy
      dz = abs( z(i)-z(j) )
      if(dz>len/2.) dz=len-dz
      rij=sqrt(dx**2+dy**2+dz**2)
    end function rij

    pure function moleculeofsite(i)
      integer :: moleculeofsite
      integer, parameter :: sitepermolecule=3 ! spc like water
      integer, intent(in) :: i
      moleculeofsite = (i-1)/sitepermolecule +1 ! division between integers: that's what we want here.
    end function moleculeofsite

    pure function kvec(l,m,n)
      double precision :: kvec(3)
      integer, intent(in) :: l,m,n
      kvec = real([l,m,n])/len
    end function kvec

    pure function k2(l,m,n)
      double precision :: k2
      integer, intent(in) :: l,m,n
      k2 = (l**2+m**2+n**2)/len**2
    end function k2

  end subroutine

end module ewald

max_stars_repo_name: maxlevesque/lasVegas

max_issues_repo_name: maxlevesque/lasVegas

max_forks_repo_name: maxlevesque/lasVegas


text:
MODULE SourceMod

   IMPLICIT NONE
   INTEGER, PARAMETER :: PRTFIL = 6, STSFIL = 10
   INTEGER, PARAMETER :: MaxNt = 10000000, MaxNST = 10000000
   INTEGER, PRIVATE   :: it_Src = 1, it, is ! it_Src used to store the current step into the source time series

CONTAINS

  SUBROUTINE SOURCE( T, S, SD, Nsd, Ntout, omega, fmin, fmax, Pulse, PulseTitle, IniFlag )

    ! Evaluate the source time series (STS) at the time vector T
    ! This should be converted to a module

    ! stemp is a temporary workspace

    ! IniFlag, used to control filtering, has to be controlled on the outside
    ! since SPARC changes the filtering as a function of wavenumber.

    LOGICAL,   INTENT( INOUT ) :: IniFlag
    INTEGER,   INTENT( IN    ) :: Ntout
    INTEGER,   INTENT( INOUT ) :: Nsd
    REAL,      INTENT( IN    ) :: T( * ), omega, fmin, fmax
    REAL,      INTENT( OUT   ) :: SD( Nsd )
    CHARACTER, INTENT( IN    ) :: Pulse*4
    CHARACTER, INTENT( OUT   ) :: PulseTitle*( * )

    INTEGER            :: Nt
    REAL               :: TF( MaxNt ), stempR( MaxNt ), deltat, TStart
    COMPLEX            :: S( Nsd, * ), stemp( MaxNt )
    EQUIVALENCE ( stempR, stemp )
    COMPLEX, ALLOCATABLE :: SF( :, : )

    SAVE TF, SF, Nt

    ! If first call, tabulate the time series

    IF ( IniFlag ) THEN
       Nt = MaxNST / NSd
       IF ( .NOT. ALLOCATED( SF ) ) ALLOCATE( SF( Nsd, Nt ) )

       IF ( Pulse( 1 : 1 ) == 'F' .OR. Pulse( 1 : 1 ) == 'B' ) THEN
          ! From a file
          CALL ReadSTS( Pulse, PulseTitle, SD, Nsd, TF, stempR, SF, Nt )
          deltat = TF( 2 ) - TF( 1 )
          !!! should check that the time series is evenly sampled, i.e. deltat constant
          !!! affects the filtering
       ELSE
          ! Use one of the canned wavelets
          Nsd    = 1
          deltat = 0.2 / omega
          TStart = -200.0 * deltat
          Nt     = 1024

          DO it = 1, Nt
             TF( it ) = TStart + ( it - 1 ) * deltat
             CALL CANS( TF( it ), omega, Pulse, SF, Nsd, it, PulseTitle )
          END DO
       ENDIF

       ! Filter the time series

       DO is = 1, Nsd
          stemp( 1 : Nt ) = SF( is, 1 : Nt ) !  Copy time series into stemp

          IF ( Pulse( 4 : 4 ) /= 'N' ) CALL BandPass( stemp, Nt, deltat, fmin, fmax )   ! Band-pass filter
          IF ( Pulse( 2 : 2 ) == 'H' ) CALL PreEnv(   stemp, Nt )   ! Form the pre-envelope
          IF ( Pulse( 2 : 2 ) == 'Q' ) CALL Hilbert(  stemp, Nt )   ! Hilbert transform

          SF( is, 1 : Nt ) = stemp( 1 : Nt )   ! Copy time series back
       END DO   ! next source depth

       IniFlag = .FALSE.
    ENDIF

    CALL EvaluateSTS( T, Pulse, TF, SF, Nsd, Nt, S, Ntout )

  END SUBROUTINE SOURCE

  !**********************************************************************C

  SUBROUTINE ReadSTS( Pulse, PulseTitle, SD, Nsd, TF, stemp, SF, Nt )

    ! Time series from file
    ! stemp is used to hold a temporary real vector

    INTEGER,   INTENT( INOUT ) :: NSd, Nt
    REAL,      INTENT( OUT   ) :: SD( NSd ), TF( * )
    COMPLEX,   INTENT( OUT   ) :: SF( Nsd, * )
    CHARACTER, INTENT( IN    ) :: Pulse*4
    CHARACTER, INTENT( OUT )   :: PulseTitle*( * )

    REAL :: stemp( Nsd ), tempV( Nsd ), temp, TMax

    OPEN( FILE = 'STSFIL', UNIT = STSFIL, STATUS = 'OLD', FORM = 'FORMATTED' )

    READ( STSFIL, * ) PulseTitle
    READ( STSFIL, * ) Nsd, SD   ! Number of source depths, vector of source depths

    ! Read in time series data

    Nt = 0
    DO it = 1, MaxNt

       READ( STSFIL, *, END = 2000 ) TF( it ), stemp

       IF ( it > 1 ) THEN
          IF ( TF( it ) < TF( it - 1 ) ) CALL ERROUT( PRTFIL, 'F', 'SOURCE:SFILE', 'Time series not ordered in time' )
       ENDIF

       SF( :, it ) = stemp
       Nt = Nt + 1

       IF ( Nt * Nsd > MaxNST ) CALL ERROUT( PRTFIL, 'F', 'SOURCE:SFILE', 'Too many time series points' )
    END DO

    ! normal exit is by EOF in file, not by falling through loop
    CALL ERROUT( PRTFIL, 'F', 'SOURCE:SFILE', 'Too many time series points' )

    ! Time reversal
    ! note if Nt is odd, middle point doesn't move

2000 IF ( Pulse( 1 : 1 ) == 'B' ) THEN
       TMax = TF( Nt )
       DO it = 1, Nt / 2
          tempV                = REAL( SF( :, it ) )
          SF( :, it )          = SF( :, Nt - it + 1 )
          SF( :, Nt - it + 1 ) = tempV

          temp                  = TMax - TF( it )
          TF( it )              = TMax - TF( Nt - it + 1 )
          TF( Nt - it + 1 )     = temp
       END DO
    ENDIF

    CLOSE( STSFIL )

  END SUBROUTINE ReadSTS

  !**********************************************************************C

  SUBROUTINE EvaluateSTS( T, Pulse, TF, SF, Nsd, Nt, S, Ntout )

    ! Evaluate the source function by linear interpolation between time samples

    INTEGER,   INTENT( IN  ) :: Nsd, Nt, Ntout
    REAL,      INTENT( IN  ) :: T( * ), TF( * )
    COMPLEX,   INTENT( IN  ) :: SF( Nsd, * )
    COMPLEX,   INTENT( OUT ) :: S( Nsd, * )
    CHARACTER, INTENT( IN  ) :: Pulse*4   ! controls a pulse sign-flip

    INTEGER :: itout
    REAL    :: W

    ! it_Src is a saved variable containing the index into the source time series at the current step

    DO itout = 1, Ntout

       ! Necessary to advance time window?

       IF ( T( itout ) < TF( it_Src ) ) it_Src = 1 ! Case of T reset to origin for new march

       !!! It is possible that the following accesses TF( Nt + 1 )
       DO WHILE ( T( itout ) > TF( it_Src + 1 ) .AND. it_Src < Nt - 1 )
          it_Src = it_Src + 1
       END DO

       ! Linear interpolation in time

       S( :, itout ) = 0.0   ! in case T outside time window

       IF ( T( itout ) >= TF( 1  ) .AND. T( itout ) <= TF( Nt ) ) THEN
          W = ( T( itout ) - TF( it_Src ) ) / ( TF( it_Src + 1 ) - TF( it_Src ) )
          S( :, itout ) = SF( :, it_Src ) + W * ( SF( :, it_Src + 1 ) - SF( :, it_Src ) )

          IF ( Pulse( 3 : 3 ) == '-' ) S( :, itout ) = -S( :, itout )
       ENDIF

    END DO   ! next itout

  END SUBROUTINE EvaluateSTS

END MODULE SourceMod

max_stars_repo_licenses: Naumen Condor-1.1 MS-PL

max_issues_repo_licenses: Naumen Condor-1.1 MS-PL

max_forks_repo_licenses: Naumen Condor-1.1 MS-PL


text:
*> \brief \b ZLAQP2 computes a QR factorization with column pivoting of the matrix block.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQP2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
*                          WORK )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, M, N, OFFSET
*       ..
*       .. Array Arguments ..
*       INTEGER            JPVT( * )
*       DOUBLE PRECISION   VN1( * ), VN2( * )
*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZLAQP2 computes a QR factorization with column pivoting of
*> the block A(OFFSET+1:M,1:N).
*> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] OFFSET
*> \verbatim
*>          OFFSET is INTEGER
*>          The number of rows of the matrix A that must be pivoted
*>          but no factorized. OFFSET >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
*>          the triangular factor obtained; the elements in block
*>          A(OFFSET+1:M,1:N) below the diagonal, together with the
*>          array TAU, represent the orthogonal matrix Q as a product of
*>          elementary reflectors. Block A(1:OFFSET,1:N) has been
*>          accordingly pivoted, but no factorized.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] JPVT
*> \verbatim
*>          JPVT is INTEGER array, dimension (N)
*>          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
*>          to the front of A*P (a leading column); if JPVT(i) = 0,
*>          the i-th column of A is a free column.
*>          On exit, if JPVT(i) = k, then the i-th column of A*P
*>          was the k-th column of A.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is COMPLEX*16 array, dimension (min(M,N))
*>          The scalar factors of the elementary reflectors.
*> \endverbatim
*>
*> \param[in,out] VN1
*> \verbatim
*>          VN1 is DOUBLE PRECISION array, dimension (N)
*>          The vector with the partial column norms.
*> \endverbatim
*>
*> \param[in,out] VN2
*> \verbatim
*>          VN2 is DOUBLE PRECISION array, dimension (N)
*>          The vector with the exact column norms.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
*  ==================
*>
*>    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*>    X. Sun, Computer Science Dept., Duke University, USA
*> \n
*>  Partial column norm updating strategy modified on April 2011
*>    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
*>    University of Zagreb, Croatia.
*
*> \par References:
*  ================
*>
*> LAPACK Working Note 176
*
*> \htmlonly
*> [PDF]
*> \endhtmlonly
*
*  =====================================================================
      SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
     $                   WORK )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      INTEGER            LDA, M, N, OFFSET
*     ..
*     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   VN1( * ), VN2( * )
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      COMPLEX*16         CONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ITEMP, J, MN, OFFPI, PVT
      DOUBLE PRECISION   TEMP, TEMP2, TOL3Z
      COMPLEX*16         AII
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZLARF, ZLARFG, ZSWAP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DCONJG, MAX, MIN, SQRT
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DZNRM2
      EXTERNAL           IDAMAX, DLAMCH, DZNRM2
*     ..
*     .. Executable Statements ..
*
      MN = MIN( M-OFFSET, N )
      TOL3Z = SQRT(DLAMCH('Epsilon'))
*
*     Compute factorization.
*
      DO 20 I = 1, MN
*
         OFFPI = OFFSET + I
*
*        Determine ith pivot column and swap if necessary.
*
         PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 )
*
         IF( PVT.NE.I ) THEN
            CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
            ITEMP = JPVT( PVT )
            JPVT( PVT ) = JPVT( I )
            JPVT( I ) = ITEMP
            VN1( PVT ) = VN1( I )
            VN2( PVT ) = VN2( I )
         END IF
*
*        Generate elementary reflector H(i).
*
         IF( OFFPI.LT.M ) THEN
            CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
     $                   TAU( I ) )
         ELSE
            CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
         END IF
*
         IF( I.LT.N ) THEN
*
*           Apply H(i)**H to A(offset+i:m,i+1:n) from the left.
*
            AII = A( OFFPI, I )
            A( OFFPI, I ) = CONE
            CALL ZLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
     $                  DCONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
     $                  WORK( 1 ) )
            A( OFFPI, I ) = AII
         END IF
*
*        Update partial column norms.
*
         DO 10 J = I + 1, N
            IF( VN1( J ).NE.ZERO ) THEN
*
*              NOTE: The following 4 lines follow from the analysis in
*              Lapack Working Note 176.
*
               TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2
               TEMP = MAX( TEMP, ZERO )
               TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
               IF( TEMP2 .LE. TOL3Z ) THEN
                  IF( OFFPI.LT.M ) THEN
                     VN1( J ) = DZNRM2( M-OFFPI, A( OFFPI+1, J ), 1 )
                     VN2( J ) = VN1( J )
                  ELSE
                     VN1( J ) = ZERO
                     VN2( J ) = ZERO
                  END IF
               ELSE
                  VN1( J ) = VN1( J )*SQRT( TEMP )
               END IF
            END IF
   10    CONTINUE
*
   20 CONTINUE
*
      RETURN
*
*     End of ZLAQP2
*
      END

max_stars_repo_name: cooparation/caffe-android

max_issues_repo_name: WatsonZhouAnda/Cheetah-Software

max_forks_repo_name: WatsonZhouAnda/Cheetah-Software


text:
The Japanese American Student Society or JASS (est. 1982) is a student organization at the University of California Davis with an eye to service, social and cultural happenings.

We deal primarily with the Japanese American community, but that doesn’t mean you have to be Japanese to join; anyone with an interest in Japanese culture and community can join our group!

EVERYONE IS WELCOME!

You can find us on Facebook too!


text:
!! R737 bounds-spec
!    is lower-bound-expr :

pointer_foo(3:,7:) => bar

end