Module mo_cost

  use mo_kind, only: sp, dp

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: cost_sp,  cost_dp
  PUBLIC :: cost_valid_sp,  cost_valid_dp
  PUBLIC :: range_sp, range_dp

CONTAINS

  FUNCTION cost_sp (paraset)

    implicit none

    REAL(SP), DIMENSION(:), INTENT(IN)  :: paraset
    REAL(SP)                            :: cost_sp
    REAL(SP), DIMENSION(6,2)            :: meas
    REAL(SP), DIMENSION(6)              :: calc

    ! function: f(x) = ax^3 + bx^2 + cx + d
    ! measurements: (0.5,5.725), (1.0, 21.7), (1.5, 49.175), (2.0, 88.9), (2.5, 141.625), (3.0, 208.1)
    ! --> a=1.0, b=20.0, c=0.2, d=0.5

    meas(:,1) = (/0.5_sp, 1.0_sp, 1.5_sp, 2.0_sp, 2.5_sp, 3.0_sp/)
    meas(:,2) = (/5.7250_sp, 21.7000_sp, 49.1750_sp, 88.9000_sp, 141.6250_sp, 208.1000_sp/)

    calc(:) = paraset(1)*meas(:,1)**3+paraset(2)*meas(:,1)**2+paraset(3)*meas(:,1)+paraset(4)

    ! MAE  Mean Absolute Error
    cost_sp = sum(abs( meas(:,2)-calc(:) ))/size(meas,1)

    RETURN
  END FUNCTION cost_sp

  FUNCTION cost_dp (paraset)

    implicit none

    REAL(DP), DIMENSION(:), INTENT(IN)  :: paraset
    REAL(DP)                            :: cost_dp
    REAL(DP), DIMENSION(6,2)            :: meas
    REAL(DP), DIMENSION(6)              :: calc

    ! function: f(x) = ax^3 + bx^2 + cx + d
    ! measurements: (0.5,5.725), (1.0, 21.7), (1.5, 49.175), (2.0, 88.9), (2.5, 141.625), (3.0, 208.1)
    ! --> a=1.0, b=20.0, c=0.2, d=0.5

    meas(:,1) = (/0.5_dp, 1.0_dp, 1.5_dp, 2.0_dp, 2.5_dp, 3.0_dp/)
    meas(:,2) = (/5.7250_dp, 21.7000_dp, 49.1750_dp, 88.9000_dp, 141.6250_dp, 208.1000_dp/)

    calc(:) = paraset(1)*meas(:,1)**3+paraset(2)*meas(:,1)**2+paraset(3)*meas(:,1)+paraset(4)

    ! MAE  Mean Absolute Error
    cost_dp = sum(abs( meas(:,2)-calc(:) ))/size(meas,1)

    RETURN
  END FUNCTION cost_dp

  FUNCTION cost_valid_sp (paraset,status_in)

    implicit none

    REAL(SP), DIMENSION(:), INTENT(IN)  :: paraset
    LOGICAL,  OPTIONAL,     INTENT(OUT) :: status_in
    REAL(SP)                            :: cost_valid_sp
    REAL(SP), DIMENSION(6,2)            :: meas
    REAL(SP), DIMENSION(6)              :: calc

    ! function: f(x) = ax^3 + bx^2 + cx + d
    ! measurements: (0.5,5.725), (1.0, 21.7), (1.5, 49.175), (2.0, 88.9), (2.5, 141.625), (3.0, 208.1)
    ! --> a=1.0, b=20.0, c=0.2, d=0.5

    meas(:,1) = (/0.5_sp, 1.0_sp, 1.5_sp, 2.0_sp, 2.5_sp, 3.0_sp/)
    meas(:,2) = (/5.7250_sp, 21.7000_sp, 49.1750_sp, 88.9000_sp, 141.6250_sp, 208.1000_sp/)

    calc(:) = paraset(1)*meas(:,1)**3+paraset(2)*meas(:,1)**2+paraset(3)*meas(:,1)+paraset(4)

    if (present(status_in)) then
       status_in = .true.
       ! Define a status .false. if calculation of "calc" was not successful
    end if

    ! MAE  Mean Absolute Error
    cost_valid_sp = sum(abs( meas(:,2)-calc(:) ))/size(meas,1)

    RETURN
  END FUNCTION cost_valid_sp

  FUNCTION cost_valid_dp (paraset,status_in)

    implicit none

    REAL(DP), DIMENSION(:), INTENT(IN)  :: paraset
    LOGICAL,  OPTIONAL,     INTENT(OUT) :: status_in
    REAL(DP)                            :: cost_valid_dp
    REAL(DP), DIMENSION(6,2)            :: meas
    REAL(DP), DIMENSION(6)              :: calc

    ! function: f(x) = ax^3 + bx^2 + cx + d
    ! measurements: (0.5,5.725), (1.0, 21.7), (1.5, 49.175), (2.0, 88.9), (2.5, 141.625), (3.0, 208.1)
    ! --> a=1.0, b=20.0, c=0.2, d=0.5

    meas(:,1) = (/0.5_dp, 1.0_dp, 1.5_dp, 2.0_dp, 2.5_dp, 3.0_dp/)
    meas(:,2) = (/5.7250_dp, 21.7000_dp, 49.1750_dp, 88.9000_dp, 141.6250_dp, 208.1000_dp/)

    calc(:) = paraset(1)*meas(:,1)**3+paraset(2)*meas(:,1)**2+paraset(3)*meas(:,1)+paraset(4)

    if (present(status_in)) then
       status_in = .true.
       ! Define a status .false. if calculation of "calc" was not successful
    end if

    ! MAE  Mean Absolute Error
    cost_valid_dp = sum(abs( meas(:,2)-calc(:) ))/size(meas,1)

    RETURN
  END FUNCTION cost_valid_dp

  SUBROUTINE range_dp(paraset, iPar, rangePar)
    use mo_kind
    REAL(DP), DIMENSION(:), INTENT(IN)  :: paraset
    INTEGER(I4),            INTENT(IN)  :: iPar
    REAL(DP), DIMENSION(2), INTENT(OUT) :: rangePar

    ! Range does not depend on parameter set
    ! select case(iPar)
    !    case(1_i4)
    !       rangePar(1) =  0.0_dp
    !       rangePar(2) = 10.0_dp
    !    case(2_i4)
    !       rangePar(1) =  0.0_dp
    !       rangePar(2) = 40.0_dp
    !    case(3_i4)
    !       rangePar(1) =  0.0_dp
    !       rangePar(2) = 10.0_dp
    !    case(4_i4)
    !       rangePar(1) =  0.0_dp
    !       rangePar(2) =  5.0_dp
    ! end select

    ! Range of parameter 2 depends on value of parameter 1:
    !    parameter 2 at most 40* parameter 1 :
    !       0 <= p2 <= 40p1
    !       0 <= p1 <= 0.025p2
    select case(iPar)
    case(1_i4)
       rangePar(1) =  0.025_dp*paraset(2)
       rangePar(2) =  10.0_dp
    case(2_i4)
       rangePar(1) =  0.0_dp
       rangePar(2) =  40.0_dp*paraset(1)
    case(3_i4)
       rangePar(1) =  0.0_dp
       rangePar(2) = 10.0_dp
    case(4_i4)
       rangePar(1) =  0.0_dp
       rangePar(2) =  5.0_dp
    end select

  END SUBROUTINE range_dp

  SUBROUTINE range_sp(paraset, iPar, rangePar)
    use mo_kind
    REAL(SP), DIMENSION(:), INTENT(IN)  :: paraset
    INTEGER(I4),            INTENT(IN)  :: iPar
    REAL(SP), DIMENSION(2), INTENT(OUT) :: rangePar

    ! Range does not depend on parameter set
    ! select case(iPar)
    !    case(1_i4)
    !       rangePar(1) =  0.0_sp
    !       rangePar(2) = 10.0_sp
    !    case(2_i4)
    !       rangePar(1) =  0.0_sp
    !       rangePar(2) = 40.0_sp
    !    case(3_i4)
    !       rangePar(1) =  0.0_sp
    !       rangePar(2) = 10.0_sp
    !    case(4_i4)
    !       rangePar(1) =  0.0_sp
    !       rangePar(2) =  5.0_sp
    ! end select

    ! Range of parameter 2 depends on value of parameter 1:
    !    parameter 2 at most 4* parameter 1 :
    !       0     <= p2 <= 4p1
    !       0.25p2 <= p1 <= 10.0
    select case(iPar)
    case(1_i4)
       rangePar(1) =  0.025_sp*paraset(2)
       rangePar(2) = 10.0_sp
    case(2_i4)
       rangePar(1) =  0.0_sp
       rangePar(2) =  40.0_sp*paraset(1)
    case(3_i4)
       rangePar(1) =  0.0_sp
       rangePar(2) = 10.0_sp
    case(4_i4)
       rangePar(1) =  0.0_sp
       rangePar(2) =  5.0_sp
    end select

  END SUBROUTINE range_sp

END MODULE mo_cost


text:
! { dg-do compile }
! Test the patch for PR30081 in which non-generic intrinsic
! procedures could not be overloaded by generic interfaces.
!
! Contributed by Harald Anlauf  <anlauf@gmx.de>
!
module gfcbug46
  interface random_seed
     module procedure put_seed
  end interface
  interface random_number
     module procedure random_vector
  end interface
  type t_t
     real :: x(2)
  end type t_t
contains
  subroutine put_seed (n, seed)
    integer, intent(inout) :: n
    integer, intent(in)    :: seed
    call random_seed (size=n)
  end subroutine put_seed
  subroutine random_vector (t)
    type(t_t) :: t
    call random_number (t% x)
  end subroutine random_vector
end module gfcbug46

  use gfcbug46
  type(t_t) :: z
  integer :: n = 2, seed = 1
  call put_seed (n, seed)
  call random_number (z)
  print *, z
end
! { dg-final { cleanup-modules "gfcbug46" } }

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


subroutine eqsolve(nsval, intflag, ierflag)

      use stel_kinds, only: dp, p4
      use name0,      only: c1pm13, &
                            c2pm8,  &
                            c1p0,   &
                            c1p4,   &
                            c100p
      use name1,      only: mnd,    &
                            nznt,   &
                            mnmax,  &
                            nsd
      use scalars,    only: ns, hs,     &
                            ohs,    &
                            mns,    &
                            neqs,   &
                            nrzt,   &
                            iter1,  &
                            iter2,  &
                            irst,   &
                            ijacob, &
                            itfsq, ns4
      use inputdat,   only: niter,  &
                            gam,    &
                            ftol, nstep
      use time,       only: delt,   &
                            timer
      use xstuff,     only: xc
      use mnarray,    only: mscale, &
                            nscale
      use fsqu,       only: wb,     &
                            wp,     &
                            fsq,    &
                            fsqr,   &
                            fsqz,   &
                            fsql,   &
                            fsqt,   &
                            wdot
      use extfld,     only: ivac,   &
                            bscale

      implicit none

      integer, intent(in)  :: nsval
      integer, intent(in)  :: intflag
      integer, intent(out) :: ierflag

      integer       :: miter
      real(kind=dp) :: w1   = 0.0_dp
      real(kind=dp) :: r01  = 0.0_dp
      real(kind=dp) :: res1 = 1.0_dp
      real(kind=dp) :: r00, w0
      real(kind=dp) :: r0dot, wdota
      real(kind=dp) :: res0
      real(kind=p4) :: t4

      !         INDEX OF LOCAL VARIABLES
      !
      ! hs      radial mesh size increment
      ! iequi   counter used to call EQFOR at end of run
      ! ijacob  counter for number of times jacobian changes sign
      ! irst    counter monitoring sign of jacobian; resets R, Z, and
      !         Lambda when jacobian changes sign and decreases time s
      ! isigng  sign of Jacobian : must be =1 (right-handed) or =-1 (left-handed)
      ! iterj   stores position in main iteration loop (j=1,2)
      ! itfsq   counter for storing FSQ into FSQT for plotting
      ! ivac    counts number of free-boundary iterations
      ! ndamp   number of iterations over which damping is averaged
      ! meven   parity selection label for even poloidal modes of R an
      ! modd    parity selection label for odd poloidal modes of R and
      ! rb      boundary coefficient array for R (rcc,rss)
      ! zb      boundary coefficient array for Z (zcs,zsc)
      ! gc      stacked array of R, Z, Lambda Spectral force coefficients
      ! xc      stacked array of scaled R, Z, Lambda Fourier coefficients
      ! STACKING ORDER:
      !   1+0*mns:1*mns   => rmncc Fourier coefficients
      !   1+1*mns,2*mns => rmnss Fourier coefficients
      !   1+2*mns,3*mns => zmncs Fourier coefficients
      !   1+3*mns,4*mns => zmnsc Fourier coefficients
      !   1+4*mns,5*mns => lmncs Fourier coefficients
      !   1+5*mns,6*mns => lmnsc Fourier coefficients
      ! note: 6*mns = neqs --> xc(1:neqs)

      ! INITIALIZE MESH-DEPENDENT SCALARS
      ns    = nsval
      hs    = c1p0/real(ns-1)
      ohs   = c1p0/hs
      mns   = ns*mnd
      neqs  = 6*mns
      nrzt  = nznt*ns
      iter2 = 1
      irst  = 1

      ! sgg
      ! DELT = C1P1
      ! DELT=0.9
      DELT=0.6

      ijacob = -1
      print   *, 'NS = ',ns,' NO. FOURIER MODES = ',mnmax
      write(3,*) 'NS = ',ns,' NO. FOURIER MODES = ',mnmax

      ! COMPUTE INITIAL R, Z AND MAGNETIC FLUX PROFILES
      ! AND STORE XC, XCDOT FOR POSSIBLE RESTART

      call profil3d(xc, xc(1+2*mns), intflag)

      ! TODO: remove need for GOTO 10 below
 10   call restart

      ijacob = ijacob+1
      iter1  = iter2

      ! FORCE ITERATION LOOP
      do miter = iter1, niter

        ! offset in number of iterations
        iter2 = miter

        ! ADVANCE FOURIER AMPLITUDES OF R, Z, AND LAMBDA
        call evolve(ierflag)
        if (ierflag.ne.0) then
          ! evolve failed --> no need to try time step --> return
          return
        end if

        r00 = xc(1)*mscale(0)*nscale(0)
        w0  = wb + wp/(gam-c1p0) ! total energy
        r0dot = abs(r00 - r01)/r00
        wdota = abs(w0 - w1)/w0
        r01 = r00
        w1  = w0

        ! COMPUTE ABSOLUTE STOPPING CRITERION
        if (     (      fsqr.le.ftol               & ! { ftol satisfied for R
                  .and. fsqz.le.ftol               & !   ftol satisfied for Z
                  .and. fsql.le.ftol               & !   ftol satisfied for lambda
                  .and. miter-iter1.gt.10)         & !   at least 10 iterations      }
            .or. (      ns.lt.nsd                  & ! { not at final multi-grid step
                  .and. (fsqr+fsqz+fsql).le.c2pm8) & !   total force residual < 2e-8 }
            .or. ijacob.ge.100                     & ! # of Jacobian resets exceeded
            .or. miter.eq.niter ) then               ! niter iterations exceeded

          ! leave force iterations loop
          exit

        endif

        if (ivac.eq.1) then
          print   110, miter, c1p0/bscale
          write(3,110) miter, c1p0/bscale
 110  format(/,'  VACUUM PRESSURE TURNED ON AT ',i4, ' ITERATIONS',/, &
               '  MAGNETIC FIELD IN PLASMA IS SCALED AT END BY ',1pe10.2,' (VAC. UNITS)',/)

          ivac = ivac + 1
        endif

        ! when using fine grid, update fsqt and wdot every 100 iterations
        if ( mod(miter, (niter/100 + 1)).eq.0 .and. (ns.eq.nsd) ) then
          itfsq       = itfsq+1
          fsqt(itfsq) = fsqr + fsqz
          wdot(itfsq) = max(wdota, c1pm13)
        end if

        ! TIME STEP CONTROL
        if (miter.eq.iter1) &
          res0 = fsq
        res0 = min(res0, fsq)

        if ( (fsq.le.res0) .and. ((iter2-iter1).gt.nsd/2) ) then
          ! forces reduced over some iterations --> save state
          call restart
        else if (fsq.gt.c100p*res1 .and. miter.gt.iter1) then
          ! forces much worse than before --> reset to saved state
          irst = 2
        else if (      fsq.gt.(c1p4*res1)      &
                 .and. mod(miter-iter1,5).eq.0 &
                 .and. (miter-iter1).gt.2*ns4  ) then
          ! bad convergence --> hard reset (?)
          irst = 3
        endif

        if (irst.ne.1) then
          ! convergence problem; need to restart from saved state
          goto 10 ! TODO: replace goto with second loop
        end if

        ! if we came here, save current value of total residual force
        res1 = res0

        ! PRINTOUT EVERY NSTEP ITERATIONS or in first iteration
        if (mod(miter,nstep).eq.0 .or. miter.eq.1) &
          call printout(iter2, w1, r00)

      enddo ! force iterations loop

      ! final printout
      call printout(iter2, w0, r00)

      ! note runtime
      call second(t4)
      timer(0) = real(t4)

      if (ijacob.ge.100) then
        ! error: more than 100 Jacobian resets
        ierflag = 2
      endif

      if (ns.lt.nsd) then
        print   100, timer(0), ijacob
        write(3,100) timer(0), ijacob
      end if
 100  format(/,' COMPUTATIONAL TIME FOR INITIAL INTERPOLATION = ',1pe10.2,' SECONDS ', &
               ' JACOBIAN RESETS = ',i4,/)

      print   60, wdota, r0dot
      write(3,60) wdota, r0dot
 60   format(/,' d(ln W)/dt = ',1pe10.3,' d(ln R0)/dt = ',1pe10.3,/)

      return

end


text:
!> @brief A simple test to see if the basic functionality of init and fin is in place.
program init_fin
  use testing_lib
  implicit none

  call init()
  call fin()
end program init_fin

max_stars_repo_name: asimovpp/asimov-ccs

max_issues_repo_name: asimovpp/asimov-ccs

max_forks_repo_name: asimovpp/asimov-ccs


text:
program main

   ! This is pi defined as a constant
   ! Most decimals will be ignored as the default precision
   ! for a single precision real data type only provides 6 to 9
   ! significant decimals
   real, parameter :: pi = 3.14159265358979323846264338327950288419716&
                          &9399375105820974944592307816406286208998628&
                          ! This comment works here and does not interrupt
                          ! the continuation line
                          &0348253421170679821480865132823066470938446&
                          ! In standard Fortran 77, anything
                          ! beyond column 72 is ignored.
                          ! In modern Fortran the limit is 132 allowing very long lines like this one
                          &09550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233&
                          ! Also comments does not count to the limit of 255 continuation lines.
                          &786783165271201909145648566923460348610454326648213393607260249141273

   print *, pi

end program

max_stars_repo_name: WVUHPC/Modern-Fortran

max_issues_repo_name: WVUHPC/Modern-Fortran

max_forks_repo_name: WVUHPC/Modern-Fortran


text:
      MODULE STRING_OPERATIONS

      IMPLICIT NONE

      CONTAINS

!      FUNCTION INT_TO_CHAR(IntNum) RESULT(CharNum)

!      INTEGER, INTENT(IN) ::       IntNum

!      CHARACTER(:), ALLOCATABLE :: CharNum

!      IF (IntNum .LE. 9) THEN

!         WRITE(CharNum, '(I1)') IntNum

!         CharNum = '00'//CharNum

!      ELSEIF (IntNum .GE. 10 .AND. IntNum .LE. 99) THEN

!         WRITE(CharNum, '(I2)') IntNum

!         CharNum = '0'//CharNum

!      ELSEIF ()

!         WRITE(CharNum, '(I3)') IntNum

!      ENDIF

!      WRITE(CharNum, '(I6)') IntNum

!      CharNum = TRIM(ADJUSTL(CharNum))

!      RETURN

!      END FUNCTION INT_TO_CHAR

      FUNCTION RM_CHAR(in_str, target_char) RESULT(out_str)

      CHARACTER(*), INTENT(IN) :: in_str

      CHARACTER :: target_char

      CHARACTER(:), ALLOCATABLE :: out_str

      CHARACTER :: ch

      INTEGER :: j

      out_str = ' '

      DO j = 1, LEN_TRIM(in_str)

         ch = in_str(j : j)

         IF (ch .NE. target_char) out_str = TRIM(out_str) // ch

      ENDDO

      out_str = TRIM(ADJUSTL(out_str))

      RETURN

      END FUNCTION RM_CHAR

      END MODULE

ext: for

max_stars_repo_name: rtagirov/nessy

max_issues_repo_name: rtagirov/nessy

max_forks_repo_name: rtagirov/nessy-src


text:
C Copyright(C) 2009-2017 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C=======================================================================
      SUBROUTINE ENGSTR (NNUM, NSIG, RNUM, RSTR, LSTR)
C=======================================================================
C$Id: engstr.f,v 1.2 2009/03/25 12:46:01 gdsjaar Exp $
C$Log: engstr.f,v $
CRevision 1.2  2009/03/25 12:46:01  gdsjaar
CAdd copyright and license notice to all files.
C
CRevision 1.1.1.1  1990/08/14 16:14:04  gdsjaar
CTesting
C
c Revision 1.1  90/08/14  16:14:03  gdsjaar
c Initial revision
c
c Revision 1.1  90/08/09  13:39:21  gdsjaar
c Initial revision
c

C   --*** ENGSTR *** (STRLIB) Convert real numbers to strings
C   --   Written by Amy Gilkey - revised 02/14/86
C   --
C   --ENGSTR converts a set of real numbers into engineering notation
C   --strings.  The real numbers are not compared in any way to get a
C   --consistent set of exponents, etc.
C   --
C   --Parameters:
C   --   NNUM - IN - the number of numbers in the array set
C   --   NSIG - IN - the maximum number of significant digits, max of 8
C   --   RNUM - IN - the array of real numbers to be converted
C   --   RSTR - OUT - the set of real number strings
C   --   LSTR - OUT - the maximum length of the number strings

C   --Routines Called:
C   --   IENGRX - (included) Get engineering notation exponent

      INTEGER NNUM
      INTEGER NSIG
      REAL RNUM(*)
      CHARACTER*(*) RSTR(*)
      INTEGER LSTR

      CHARACTER*10 SCRFMT
      CHARACTER*20 SCRSTR
      CHARACTER*15 FFMT

C   --Do not try to use a common exponent, but use engineering notation

      WRITE (SCRFMT, 10, IOSTAT=IDUM) NSIG+7, NSIG
   10 FORMAT ('(0PE', I2.2, '.', I2.2, ')')

      LSTR = 0
      DO 40 I = 1, NNUM
         WRITE (SCRSTR(1:NSIG+7), SCRFMT, IOSTAT=IDUM) RNUM(I)
         READ (SCRSTR(NSIG+5:NSIG+7), '(I3)', IOSTAT=IDUM) IE
         ISIGN = 0
         IF (RNUM(I) .LT. 0.0) ISIGN = 1

         NEWEXP = IENGRX (IE, IE)

         EXPDIV = 10.0 ** NEWEXP

         NWHOLE = MAX (0, IE - NEWEXP)
         NFRAC = MAX (0, MIN (NEWEXP - IE + NSIG,
     &      NSIG - (IE - NEWEXP)))
         NTOTAL = ISIGN + NWHOLE + 1 + NFRAC

         WRITE (FFMT, 20, IOSTAT=IDUM) NTOTAL, NFRAC
   20    FORMAT ('(F', I2.2, '.', I2.2, ')')
         WRITE (FFMT(8:15), 30, IOSTAT=IDUM) NEWEXP
   30    FORMAT (',''E', SP, I3.2, ''')')
         LSTR = MAX (LSTR, NTOTAL+4)

         WRITE (RSTR(I), FFMT, IOSTAT=IDUM) RNUM(I)/EXPDIV
   40 CONTINUE

      RETURN
      END

ext: f

max_stars_repo_name: mathstuf/seacas

max_stars_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_issues_repo_name: mathstuf/seacas

max_issues_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_forks_repo_name: mathstuf/seacas

max_forks_repo_licenses: BSD-3-Clause NetCDF Zlib MIT


text:
c
c -------------------------------------------------------
c
      subroutine fluxad(xfluxm,xfluxp,yfluxm,yfluxp,
     1                  svdflx,mptr,mitot,mjtot,
     2                   nvar,lenbc,lratiox,lratioy,ng,dtf,dx,dy)
c

      implicit double precision (a-h,o-z)

      include  "call.i"

c :::::::::::::::::::: FLUXAD ::::::::::::::::::::::::::::::::::
c  save fine grid fluxes  at the border of the grid, for fixing
c  up the adjacent coarse cells. at each edge of the grid, only
c  save the plus or minus fluxes, as necessary. For ex., on
c  left edge of fine grid, it is the minus xfluxes that modify the
c  coarse cell.
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

      dimension xfluxm(mitot,mjtot,nvar), yfluxm(mitot,mjtot,nvar)
      dimension xfluxp(mitot,mjtot,nvar), yfluxp(mitot,mjtot,nvar)
      dimension svdflx(nvar,lenbc)

      nx  = mitot-2*ng
      ny  = mjtot-2*ng
      nyc = ny/lratioy
      nxc = nx/lratiox

c ::::: left side saved first
      lind = 0

      do 100 j=1,nyc
         lind = lind + 1
         jfine = (j-1)*lratioy + ng
         do 110 ivar = 1, nvar
            do 120 l=1,lratioy
               svdflx(ivar,lind) = svdflx(ivar,lind) +
     1                             xfluxm(ng+1,jfine+l,ivar)*dtf*dy
c              write(dbugunit,900)lind,xfluxm(1,jfine+l,ivar),
c     .                           xfluxp(1,jfine+l,ivar)
 900           format(' lind ', i4,' m & p ',2e15.7,' svd ',e15.7)
120         continue
110      continue
100   continue

c ::::: top side
c      write(dbugunit,*)" saving top side "
      do 200 i=1,nxc
         lind = lind + 1
         ifine = (i-1)*lratiox + ng
         do 210 ivar = 1, nvar
            do 220 l=1,lratiox
               svdflx(ivar,lind) = svdflx(ivar,lind) +
     1                     yfluxp(ifine+l,mjtot-ng+1,ivar)*dtf*dx
c              write(dbugunit,900)lind,yfluxm(ifine+l,mjtot-ng+1,
c     .                           ivar),yfluxp(ifine+l,mjtot-ng+1,ivar),
c     .                           svdflx(ivar,lind)
220         continue
210      continue
200   continue

c ::::: right side
      do 300 j=1,nyc
         lind = lind + 1
         jfine = (j-1)*lratioy + ng
         do 310 ivar = 1, nvar
            do 320 l=1,lratioy
               svdflx(ivar,lind) = svdflx(ivar,lind) +
     1                     xfluxp(mitot-ng+1,jfine+l,ivar)*dtf*dy
c              write(dbugunit,900)lind,xfluxm(mitot-ng+1,jfine+l,
c                                 ivar),xfluxp(mitot-ng+1,jfine+l,ivar)
320         continue
310      continue
300   continue

c ::::: bottom side
c      write(dbugunit,*)" saving bottom side "
      do 400 i=1,nxc
         lind = lind + 1
         ifine = (i-1)*lratiox + ng
         do 410 ivar = 1, nvar
            do 420 l=1,lratiox
               svdflx(ivar,lind) = svdflx(ivar,lind) +
     1                             yfluxm(ifine+l,ng+1,ivar)*dtf*dx
c              write(dbugunit,900)lind,yfluxm(ifine+l,ng+1,ivar),
c     .                      yfluxp(ifine+l,ng+1,ivar),svdflx(ivar,lind)
420         continue
410      continue
400   continue

      return
      end

max_issues_repo_name: che-wenchao/D-Claw

max_forks_repo_name: che-wenchao/D-Claw


text:
module rnd_lib
 implicit none
 interface random
  module procedure d1rnd,z1rnd,d2rnd,z2rnd,d3rnd,z3rnd
 end interface
contains

 subroutine arnd()
  implicit none
  integer s,clock,crate,cmax
  integer,allocatable :: seed(:)
  call random_seed(size=s)
  allocate(seed(s))
  call random_seed(get=seed)
  write(*,*) 'oldseed: ',seed
  call system_clock(clock,crate,cmax)
  !write(*,*)clock,crate,cmax
  seed(1)=clock
  call random_seed(put=seed)
  write(*,*) 'newseed: ',seed
 end subroutine

 double precision function drnd( )
  implicit none
  call random_number(drnd)
 return
 end function

 subroutine d1rnd(d)
  double precision,intent(out)  :: d(:)
  call random_number(d)
 end subroutine
 subroutine z1rnd(z)
  implicit none
  double complex,intent(inout)  :: z(:)
  character(len=*),parameter :: subnam='z1rnd'
  double precision,allocatable :: d(:)
  integer :: n,info
  n=size(z)
  allocate(d(2*n),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': cannot allocate';stop;endif
  call random_number(d)
  call dcopy(2*n,d,1,z,1)
  deallocate(d)
 end subroutine

 subroutine d2rnd(d)
  double precision,intent(out)  :: d(:,:)
  call random_number(d)
 end subroutine
 subroutine z2rnd(z)
  implicit none
  double complex,intent(inout)  :: z(:,:)
  character(len=*),parameter :: subnam='z2rnd'
  double precision,allocatable :: d(:)
  integer :: n,info
  n=size(z)
  allocate(d(2*n),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': cannot allocate';stop;endif
  call random_number(d)
  call dcopy(2*n,d,1,z,1)
  deallocate(d)
 end subroutine

 subroutine d3rnd(d)
  double precision,intent(out)  :: d(:,:,:)
  call random_number(d)
 end subroutine
 subroutine z3rnd(z)
  implicit none
  double complex,intent(inout)  :: z(:,:,:)
  character(len=*),parameter :: subnam='z3rnd'
  double precision,allocatable :: d(:)
  integer :: n,info
  n=size(z)
  allocate(d(2*n),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': cannot allocate';stop;endif
  call random_number(d)
  call dcopy(2*n,d,1,z,1)
  deallocate(d)
 end subroutine

 integer function irnd( maxi )
  integer,intent(in) :: maxi
  double precision :: d
  call random_number(d)
  irnd=int(d*maxi)+1
 return
 end function
 subroutine irand(maxi,ix)
  integer,intent(in)  :: maxi
  integer,intent(out) :: ix(:)
  integer :: i,n
  double precision,allocatable :: d(:)
  n=size(ix)
  allocate(d(n))
  call random_number(d)
  ix=int(d*maxi)+1
  deallocate(d)
 return
 end subroutine

end module

max_stars_repo_name: dimpase/tt-fort

max_issues_repo_name: dimpase/tt-fort

max_forks_repo_name: dimpase/tt-fort


text:
      program feff
      integer iabs, nabs
      logical ceels !KJ added ceels 5-06

      call rdinp(nabs,ceels)
      call ffmod1
      call ffmod2
      do 900 iabs = 1, nabs
        if (nabs.gt.1) call ffsort (iabs,ceels) !KJ 5-6 added second argument
        call ffmod4
        call ffmod5
        call ffmod6(iabs)
        call ffmod9
 900  continue
      stop
      end


module netcdf_io_module
implicit none

contains

 subroutine create( filename, ID , mode )
 use netcdf

  character(len=*), intent(in):: filename
  integer, intent(out):: ID
  integer, intent(in), optional:: mode
  integer:: ierr

  if (present(mode)) then
    ierr = nf90_create( filename, mode, ID )
  else
    ierr = nf90_create( filename, NF90_CLOBBER, ID )
  end if
  call isitok(ierr,'Error while creating output file '//filename)

 end subroutine

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

 subroutine open_file( filename, ID , mode )
 use netcdf

  character(len=*), intent(in):: filename
  integer, intent(out):: ID
  integer, intent(in), optional:: mode
  integer:: ierr

  if (present(mode)) then
    ierr = nf90_open( filename, mode, ID )
  else
    ierr = nf90_open( filename, NF90_NOWRITE, ID )
  end if
  call isitok(ierr,'Error while openning file '//filename)

 end subroutine

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

 subroutine enddef( ID )
 use netcdf

  integer, intent(in):: ID
  character(len=30):: num
  integer:: ierr

  ierr = nf90_enddef( ID )
  write(num,fmt="(I0)") ID
  call isitok(ierr,'Error while end of definition of output file #'//trim(num))

 end subroutine

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

 subroutine redef( ID )
 use netcdf

  integer, intent(in):: ID
  character(len=30):: num
  integer:: ierr

  ierr = nf90_redef( ID )
  write(num,fmt="(I0)") ID
  call isitok(ierr,'Error while returning into define mode of output file #'//trim(num))

 end subroutine

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

 subroutine close_file( ID )
 use netcdf

  integer, intent(in):: ID
  character(len=30):: num
  integer:: ierr

  ierr = nf90_close( ID )
  write(num,fmt="(I0)") ID
  call isitok(ierr,'Error while closing output file #'//trim(num))

 end subroutine

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

 subroutine def_dim( ID, dimname , length, dimid )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), dimension(:), intent(in):: dimname
  integer, dimension(:), intent(in):: length
  integer, dimension(:), intent(out):: dimid
  integer:: ierr, N, i

  N = size(dimname,1)

  !===============================================================!
  do i=1,N
    ierr = nf90_def_dim( ID, dimname(i) , length(i), dimid(i) )
    call isitok(ierr,'Error while defining dimension '//dimname(i))
  end do
  !===============================================================!

 end subroutine

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

 subroutine def_var( ID, varname, vartype, dimid, varid )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), dimension(:), intent(in):: varname
  integer, dimension(:), intent(in):: vartype, dimid
  integer, dimension(:), intent(out):: varid
  integer, allocatable:: vec_types(:)
  integer:: ierr, N, i

  N = size(varid,1)
  allocate(vec_types(N))

  if (size(vartype,1)==1) then
    vec_types = vartype(1)
  else
    vec_types = vartype
  end if

  !==================================================================!
  do i=1,N
    ierr=nf90_def_var( ID, varname(i), vec_types(i), dimid, varid(i) )
    call isitok(ierr,'Error while defining variable '//varname(i))
  end do
  !==================================================================!

 end subroutine

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

 subroutine put_att_text( ID, varid, attname, attribute )
 use netcdf

  integer, intent(in):: ID ! file identifier
  integer, dimension(:), intent(in):: varid
  character(len=*), dimension(:), intent(in):: attname, attribute
!  character(len=:), dimension(:), allocatable:: vec_attname, vec_attribute
  character(len=200), dimension(:), allocatable:: vec_attname, vec_attribute
  integer:: ierr, l, l2, N, i
  character(len=30):: num

  N = size(varid,1)
!  l = len(attname)
!  l2 = len(attribute)
!  allocate( character(len=l)::  vec_attname(N)   )
!  allocate( character(len=l2):: vec_attribute(N) )
! This syntax is not supported by ifort10.1.021, character variables length must be imposed
  allocate( vec_attname(N)   )
  allocate( vec_attribute(N) )

  if (size(attname,1)==1) then
    vec_attname = attname(1)
  else
    vec_attname = attname
  end if

  if (size(attribute,1)==1) then
    vec_attribute = attribute(1)
  else
    vec_attribute = attribute
  end if

  !======================================================================================!
  do i=1,N
    ierr=nf90_put_att( ID, varid(i) , vec_attname(i), vec_attribute(i) )
    write(num,fmt="(I0)") i
    call isitok(ierr,'Error while putting variable #'//trim(num)//' attribute: '//vec_attname(i))
  end do
  !======================================================================================!

 end subroutine

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

 subroutine put_att_real( ID, varid, attname, attribute )
 use netcdf

  integer, intent(in):: ID ! file identifier
  integer, dimension(:), intent(in):: varid
  character(len=*), dimension(:), intent(in):: attname
!  character(len=:), dimension(:), allocatable:: vec_attname
  character(len=200), dimension(:), allocatable:: vec_attname
  real, dimension(:), intent(in):: attribute
  real, dimension(:), allocatable:: vec_attribute
  integer:: ierr, N, l, i
  character(len=30):: num

  N = size(varid,1)
  l = len(attname)
!  allocate( character(len=l):: vec_attname(N) )
! This syntax is not supported by ifort10.1.021, character variables length must be imposed
  allocate( vec_attname(N) )
  allocate( vec_attribute(N) )

  if (size(attname,1)==1) then
    vec_attname = attname(1)
  else
    vec_attname = attname
  end if

  if (size(attribute,1)==1) then
    vec_attribute = attribute(1)
  else
    vec_attribute = attribute
  end if

  !======================================================================================!
  do i=1,N
    ierr=nf90_put_att( ID, varid(i) , vec_attname(i), vec_attribute(i) )
    write(num,fmt="(I0)") i
    call isitok(ierr,'Error while putting variable #'//trim(num)//' attribute: '//vec_attname(i))
  end do
  !======================================================================================!

 end subroutine

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

 subroutine put_att_dble( ID, varid, attname, attribute )
 use netcdf

  integer, intent(in):: ID ! file identifier
  integer, dimension(:), intent(in):: varid
  character(len=*), dimension(:), intent(in):: attname
!  character(len=:), dimension(:), allocatable:: vec_attname
  character(len=200), dimension(:), allocatable:: vec_attname
  double precision, dimension(:), intent(in):: attribute
  double precision, dimension(:), allocatable:: vec_attribute
  integer:: ierr, N, l, i
  character(len=30):: num

  N = size(varid,1)
  l = len(attname)
!  allocate( character(len=l):: vec_attname(N) )
! This syntax is not supported by ifort10.1.021, character variables length must be imposed
  allocate( vec_attname(N) )
  allocate( vec_attribute(N) )

  if (size(attname,1)==1) then
    vec_attname = attname(1)
  else
    vec_attname = attname
  end if

  if (size(attribute,1)==1) then
    vec_attribute = attribute(1)
  else
    vec_attribute = attribute
  end if

  !======================================================================================!
  do i=1,N
    ierr=nf90_put_att( ID, varid(i) , vec_attname(i), vec_attribute(i) )
    write(num,fmt="(I0)") i
    call isitok(ierr,'Error while putting variable #'//trim(num)//' attribute: '//vec_attname(i))
  end do
  !======================================================================================!

 end subroutine

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

 subroutine put_att_int( ID, varid, attname, attribute )
 use netcdf

  integer, intent(in):: ID ! file identifier
  integer, dimension(:), intent(in):: varid
  character(len=*), dimension(:), intent(in):: attname
!  character(len=:), dimension(:), allocatable:: vec_attname
  character(len=200), dimension(:), allocatable:: vec_attname
  integer, dimension(:), intent(in):: attribute
  integer, dimension(:), allocatable:: vec_attribute
  integer:: ierr, N, l, i
  character(len=30):: num

  N = size(varid,1)
  l = len(attname)
!  allocate( character(len=l):: vec_attname(N) )
! This syntax is not supported by ifort10.1.021, character variables length must be imposed
  allocate( vec_attname(N) )
  allocate( vec_attribute(N) )

  if (size(attname,1)==1) then
    vec_attname = attname(1)
  else
    vec_attname = attname
  end if

  if (size(attribute,1)==1) then
    vec_attribute = attribute(1)
  else
    vec_attribute = attribute
  end if

  !======================================================================================!
  do i=1,N
    ierr=nf90_put_att( ID, varid(i) , vec_attname(i), vec_attribute(i) )
    write(num,fmt="(I0)") i
    call isitok(ierr,'Error while putting variable #'//trim(num)//' attribute: '//vec_attname(i))
  end do
  !======================================================================================!

 end subroutine

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

 subroutine get_var_real1D( ID, varname, VAR, units, missval_name ,missval, stt, cnt )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), intent(in):: varname
  real, dimension(:), intent(out):: VAR
  character(len=*), intent(out), optional:: units
  character(len=*), intent(in), optional:: missval_name
  real, intent(out), optional:: missval
  integer, intent(in), dimension(:), optional:: stt, cnt

  character(len=50):: missval_n
  integer:: varid, ierr, i, l, n

  ierr = nf90_inq_varid( ID, varname, varid )
  call isitok(ierr,'Error while getting '//varname//' variable identifiers')
  if (present(stt) .and. present(cnt)) then
    ierr = nf90_get_var( ID, varid, VAR , start=stt, count=cnt)
  else
    ierr = nf90_get_var( ID, varid, VAR )
  end if
  call isitok(ierr,'Error while getting variable '//varname)

  if (present(units)) then
    ierr = nf90_get_att( ID, varid, 'units', units)
    call isitok(ierr,'Error while getting variable '//varname//' attribute "units"')
  end if

  if (present(missval)) then
    if (present(missval_name)) then
      l=len(missval_name)
      missval_n(1:l) = missval_name
    else
      l=10
      missval_n(1:l) = '_Fillvalue'
    end if
    ierr = nf90_get_att( ID, varid, missval_n(1:l), missval)
    call isitok(ierr,'Error while getting variable '//varname//' attribute '//missval_n(1:l))
  end if

 end subroutine

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

 subroutine get_var_real2D( ID, varname, VAR, units, missval_name ,missval, stt, cnt )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), intent(in):: varname
  real, dimension(:,:), intent(out):: VAR
  character(len=*), intent(out), optional:: units
  character(len=*), intent(in), optional:: missval_name
  real, intent(out), optional:: missval
  integer, intent(in), dimension(:), optional:: stt, cnt

  character(len=50):: missval_n
  integer:: varid, ierr, i, l, n

  ierr = nf90_inq_varid( ID, varname, varid )
  call isitok(ierr,'Error while getting '//varname//' variable identifiers')
  if (present(stt) .and. present(cnt)) then
    ierr = nf90_get_var( ID, varid, VAR , start=stt, count=cnt)
  else
    ierr = nf90_get_var( ID, varid, VAR )
  end if
  call isitok(ierr,'Error while getting variable '//varname)

  if (present(units)) then
    ierr = nf90_get_att( ID, varid, 'units', units)
    call isitok(ierr,'Error while getting variable '//varname//' attribute "units"')
  end if

  if (present(missval)) then
    if (present(missval_name)) then
      l=len(missval_name)
      missval_n(1:l) = missval_name
    else
      l=10
      missval_n(1:l) = '_Fillvalue'
    end if
    ierr = nf90_get_att( ID, varid, missval_n(1:l), missval)
    call isitok(ierr,'Error while getting variable '//varname//' attribute '//missval_n(1:l))
  end if

 end subroutine

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

 subroutine get_var_real3D( ID, varname, VAR, units, missval_name ,missval, stt, cnt )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), intent(in):: varname
  real, dimension(:,:,:), intent(out):: VAR
  character(len=*), intent(out), optional:: units
  character(len=*), intent(in), optional:: missval_name
  real, intent(out), optional:: missval
  integer, intent(in), dimension(:), optional:: stt, cnt

  character(len=50):: missval_n
  integer:: varid, ierr, i, l, n

  ierr = nf90_inq_varid( ID, varname, varid )
  call isitok(ierr,'Error while getting '//varname//' variable identifiers')
  if (present(stt) .and. present(cnt)) then
    ierr = nf90_get_var( ID, varid, VAR , start=stt, count=cnt)
  else
    ierr = nf90_get_var( ID, varid, VAR )
  end if
  call isitok(ierr,'Error while getting variable '//varname)

  if (present(units)) then
    ierr = nf90_get_att( ID, varid, 'units', units)
    call isitok(ierr,'Error while getting variable '//varname//' attribute "units"')
  end if

  if (present(missval)) then
    if (present(missval_name)) then
      l=len(missval_name)
      missval_n(1:l) = missval_name
    else
      l=10
      missval_n(1:l) = '_Fillvalue'
    end if
    ierr = nf90_get_att( ID, varid, missval_n(1:l), missval)
    call isitok(ierr,'Error while getting variable '//varname//' attribute '//missval_n(1:l))
  end if

 end subroutine

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

 subroutine get_var_real4D( ID, varname, VAR, units, missval_name ,missval, stt, cnt )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), intent(in):: varname
  real, dimension(:,:,:,:), intent(out):: VAR
  character(len=*), intent(out), optional:: units
  character(len=*), intent(in), optional:: missval_name
  real, intent(out), optional:: missval
  integer, intent(in), dimension(:), optional:: stt, cnt

  character(len=50):: missval_n
  integer:: varid, ierr, i, l, n

  ierr = nf90_inq_varid( ID, varname, varid )
  call isitok(ierr,'Error while getting '//varname//' variable identifiers')
  if (present(stt) .and. present(cnt)) then
    ierr = nf90_get_var( ID, varid, VAR , start=stt, count=cnt)
  else
    ierr = nf90_get_var( ID, varid, VAR )
  end if
  call isitok(ierr,'Error while getting variable '//varname)

  if (present(units)) then
    ierr = nf90_get_att( ID, varid, 'units', units)
    call isitok(ierr,'Error while getting variable '//varname//' attribute "units"')
  end if

  if (present(missval)) then
    if (present(missval_name)) then
      l=len(missval_name)
      missval_n(1:l) = missval_name
    else
      l=10
      missval_n(1:l) = '_Fillvalue'
    end if
    ierr = nf90_get_att( ID, varid, missval_n(1:l), missval)
    call isitok(ierr,'Error while getting variable '//varname//' attribute '//missval_n(1:l))
  end if

 end subroutine

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

 subroutine get_var_dble1D( ID, varname, VAR, units, missval_name ,missval, stt, cnt )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), intent(in):: varname
  double precision, dimension(:), intent(out):: VAR
  character(len=*), intent(out), optional:: units
  character(len=*), intent(in), optional:: missval_name
  double precision, intent(out), optional:: missval
  integer, intent(in), dimension(:), optional:: stt, cnt

  character(len=50):: missval_n
  integer:: varid, ierr, i, l, n

  ierr = nf90_inq_varid( ID, varname, varid )
  call isitok(ierr,'Error while getting '//varname//' variable identifiers')
  if (present(stt) .and. present(cnt)) then
    ierr = nf90_get_var( ID, varid, VAR , start=stt, count=cnt)
  else
    ierr = nf90_get_var( ID, varid, VAR )
  end if
  call isitok(ierr,'Error while getting variable '//varname)

  if (present(units)) then
    ierr = nf90_get_att( ID, varid, 'units', units)
    call isitok(ierr,'Error while getting variable '//varname//' attribute "units"')
  end if

  if (present(missval)) then
    if (present(missval_name)) then
      l=len(missval_name)
      missval_n(1:l) = missval_name
    else
      l=10
      missval_n(1:l) = '_Fillvalue'
    end if
    ierr = nf90_get_att( ID, varid, missval_n(1:l), missval)
    call isitok(ierr,'Error while getting variable '//varname//' attribute '//missval_n(1:l))
  end if

 end subroutine

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

 subroutine get_var_dble2D( ID, varname, VAR, units, missval_name ,missval, stt, cnt )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), intent(in):: varname
  double precision, dimension(:,:), intent(out):: VAR
  character(len=*), intent(out), optional:: units
  character(len=*), intent(in), optional:: missval_name
  double precision, intent(out), optional:: missval
  integer, intent(in), dimension(:), optional:: stt, cnt

  character(len=50):: missval_n
  integer:: varid, ierr, i, l, n

  ierr = nf90_inq_varid( ID, varname, varid )
  call isitok(ierr,'Error while getting '//varname//' variable identifiers')
  if (present(stt) .and. present(cnt)) then
    ierr = nf90_get_var( ID, varid, VAR , start=stt, count=cnt)
  else
    ierr = nf90_get_var( ID, varid, VAR )
  end if
  call isitok(ierr,'Error while getting variable '//varname)

  if (present(units)) then
    ierr = nf90_get_att( ID, varid, 'units', units)
    call isitok(ierr,'Error while getting variable '//varname//' attribute "units"')
  end if

  if (present(missval)) then
    if (present(missval_name)) then
      l=len(missval_name)
      missval_n(1:l) = missval_name
    else
      l=10
      missval_n(1:l) = '_Fillvalue'
    end if
    ierr = nf90_get_att( ID, varid, missval_n(1:l), missval)
    call isitok(ierr,'Error while getting variable '//varname//' attribute '//missval_n(1:l))
  end if

 end subroutine

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

 subroutine get_var_dble3D( ID, varname, VAR, units, missval_name ,missval, stt, cnt )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), intent(in):: varname
  double precision, dimension(:,:,:), intent(out):: VAR
  character(len=*), intent(out), optional:: units
  character(len=*), intent(in), optional:: missval_name
  double precision, intent(out), optional:: missval
  integer, intent(in), dimension(:), optional:: stt, cnt

  character(len=50):: missval_n
  integer:: varid, ierr, i, l, n

  ierr = nf90_inq_varid( ID, varname, varid )
  call isitok(ierr,'Error while getting '//varname//' variable identifiers')
  if (present(stt) .and. present(cnt)) then
    ierr = nf90_get_var( ID, varid, VAR , start=stt, count=cnt)
  else
    ierr = nf90_get_var( ID, varid, VAR )
  end if
  call isitok(ierr,'Error while getting variable '//varname)

  if (present(units)) then
    ierr = nf90_get_att( ID, varid, 'units', units)
    call isitok(ierr,'Error while getting variable '//varname//' attribute "units"')
  end if

  if (present(missval)) then
    if (present(missval_name)) then
      l=len(missval_name)
      missval_n(1:l) = missval_name
    else
      l=10
      missval_n(1:l) = '_Fillvalue'
    end if
    ierr = nf90_get_att( ID, varid, missval_n(1:l), missval)
    call isitok(ierr,'Error while getting variable '//varname//' attribute '//missval_n(1:l))
  end if

 end subroutine

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

 subroutine get_var_dble4D( ID, varname, VAR, units, missval_name ,missval, stt, cnt )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), intent(in):: varname
  double precision, dimension(:,:,:,:), intent(out):: VAR
  character(len=*), intent(out), optional:: units
  character(len=*), intent(in), optional:: missval_name
  double precision, intent(out), optional:: missval
  integer, intent(in), dimension(:), optional:: stt, cnt

  character(len=50):: missval_n
  integer:: varid, ierr, i, l, n

  ierr = nf90_inq_varid( ID, varname, varid )
  call isitok(ierr,'Error while getting '//varname//' variable identifiers')
  if (present(stt) .and. present(cnt)) then
    ierr = nf90_get_var( ID, varid, VAR , start=stt, count=cnt)
  else
    ierr = nf90_get_var( ID, varid, VAR )
  end if
  call isitok(ierr,'Error while getting variable '//varname)

  if (present(units)) then
    ierr = nf90_get_att( ID, varid, 'units', units)
    call isitok(ierr,'Error while getting variable '//varname//' attribute "units"')
  end if

  if (present(missval)) then
    if (present(missval_name)) then
      l=len(missval_name)
      missval_n(1:l) = missval_name
    else
      l=10
      missval_n(1:l) = '_Fillvalue'
    end if
    ierr = nf90_get_att( ID, varid, missval_n(1:l), missval)
    call isitok(ierr,'Error while getting variable '//varname//' attribute '//missval_n(1:l))
  end if

 end subroutine

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

 subroutine put_var_real1D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  real, dimension(:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_real2D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  real, dimension(:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_real3D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  real, dimension(:,:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_real4D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  real, dimension(:,:,:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_dble1D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  double precision, dimension(:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_dble2D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  double precision, dimension(:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_dble3D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  double precision, dimension(:,:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_dble4D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  double precision, dimension(:,:,:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_int1D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  integer, dimension(:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_int2D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  integer, dimension(:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_int3D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  integer, dimension(:,:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine put_var_int4D( ID, varid, VAR, begin, length )
 use netcdf

  integer, intent(in):: ID, varid
  integer, dimension(:,:,:,:), intent(in):: VAR
  integer, dimension(:), optional:: begin, length
  integer:: ierr
  character(len=30):: num

  !==============================================================!
  if ( present(begin) .and. present(length) ) then
    ierr=nf90_put_var( ID, varid ,VAR, start=begin, count=length )
  else
    ierr=nf90_put_var( ID, varid ,VAR )
  end if
  write(num,fmt="(I0)") varid
  call isitok(ierr,'Error while putting variable #'//trim(num))
  !==============================================================!

 end subroutine

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

 subroutine inquire_dim( ID, dimname, dimid )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), dimension(:), intent(in):: dimname
  integer, dimension(:), intent(out):: dimid
  integer:: ierr, N, i

  N = size(dimname,1)

  !===============================================================================!
  do i=1,N
    ierr = nf90_inq_dimid( ID, dimname(i) , dimid(i) )
    call isitok(ierr,'Error while inquiring dimension '//dimname(i)//' identifier')
  end do
  !===============================================================================!

 end subroutine

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

 subroutine inquire_var( ID, varname, varid )
 use netcdf

  integer, intent(in):: ID ! file identifier
  character(len=*), dimension(:), intent(in):: varname
  integer, dimension(:), intent(out):: varid
  integer:: ierr, N, i

  N = size(varid,1)

  !==============================================================================!
  do i=1,N
    ierr=nf90_inq_varid( ID, varname(i), varid(i) )
    call isitok(ierr,'Error while inquiring variable '//varname(i)//' identifier')
  end do
  !==============================================================================!

 end subroutine

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

  subroutine check_fillvalue( ID, varid, fillvalname, fillval )
  use netcdf

   integer, intent(in):: ID ! file identifier
   integer, dimension(:), intent(in):: varid
   character(len=*), dimension(:), intent(in):: fillvalname
   real, dimension(:), intent(inout):: fillval
   real:: fillvalue
   integer:: ierr, N, i
   character(len=30):: num

   N = size(varid,1)

   !=======================================================================================!
   do i=1,N
     ierr=nf90_get_att( ID, varid(i), fillvalname(i), fillvalue )
     write(num,fmt="(I0)") varid(i)
     call isitok(ierr,'Error while checking variable #'//trim(num)//' attribute '//fillvalname(i))
       if ( ierr/=NF90_NOERR ) then
         print *, 'CANNOT TEST MISSING-VALUE CONSISTENCY. PROGRAM STOPPED'
         stop
       else
         if ( fillvalue /= fillval(i) ) then
           print *, 'WARNING: variable #'//trim(num)//' missing-value is not consistent with'
           print *, 'existing file. It will be changed to keep existing file value'
           fillval(i) = fillvalue
         end if
       end if
   end do
   !======================================================================================!

  end subroutine

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

 subroutine isitok(ierr,message)
 use netcdf
   integer, intent(in):: ierr
   character(len=*), intent(in):: message
   if (ierr/=NF90_NOERR) then
     print *
     print *, message
     print *, nf90_strerror(ierr)
     stop
   end if
 end subroutine

end module


text: The Journal of Mathematical Physics is published monthly by the American Institute of Physics.  The editor is Professor Bruno Nachtergaele, and associate editor is Alexander Soshnikov.  Both are faculty of UC Davis Mathematics Department.  The physical offices are located on the third floor of the Mathematical Sciences Building MSB.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
subroutine clawpack46_b4step3(mbc,mx,my,mz,meqn,q,xlower,ylower,zlower, &
    dx,dy,dz,t,dt,maux,aux)

    ! Called before each call to step3.
    ! Use to set time-dependent aux arrays or perform other tasks.
    !
    ! This default version does nothing.

    implicit none
    integer  :: mbc,mx,my,mz,meqn,maux
    double precision  :: xlower,ylower,zlower,dx,dy,dz,t,dt
    double precision  :: q(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,meqn)
    double precision  :: aux(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,maux)

end subroutine clawpack46_b4step3

max_stars_repo_name: ECLAIRWaveS/ForestClaw

max_issues_repo_name: ECLAIRWaveS/ForestClaw

max_forks_repo_name: ECLAIRWaveS/ForestClaw


text:
module Test
  implicit none
  integer :: dim = 10

contains
  subroutine DefineCluster( SitePotential, Sites, weakL, weakR, ClusterSize )
    implicit none

    ! Inputs
    real, dimension(dim), intent(in) :: SitePotential
    integer, intent(in) :: weakL, weakR
    integer, intent(in) :: ClusterSize

    ! Outputs
    real, dimension(ClusterSize), intent(out) :: Sites

    ! Other
    integer :: EndSite, FirstSite

    if ( weakL .gt. weakR ) then
       EndSite = dim - weakL
       Sites(1:EndSite) = SitePotential((weakL):(dim - sitesremoved))
       Sites((EndSite+1):ClusterSize) = SitePotential(1:weakR)
    else if ( (weakL .gt. weakR) .and. ( ClusterSize .eq. 1 ) ) then
       Sites = SitePotential(weakR:weakR)
    else if ( size(SitePotential) .eq. ClusterSize ) then
       Sites = SitePotential
    else
       Sites = SitePotential((weakL+1):weakR)
    end if

  end subroutine DefineCluster

end module Test

program Prog
  implicit none

  integer :: i, weakL, weakR, ClusterSize
  real :: SitePotential(dim), Sites(4)

  weakL = 7

  do i=1,dim
     SitePotential(i) = i
  end do

max_stars_repo_name: djallum/AHMCodeNN

max_issues_repo_name: djallum/AHMCodeNN

max_forks_repo_name: djallum/AHMCodeNN


text:
Bike Church Mission

This is the Bike church mission statement page to be edited by bike church members to reflect what we feel the mission of the church entails.

Meeting Ideas

Roundtable discussion occurred regarding what each person envisioned the Bike Church to be.  These main points were that the Bike Church be a place where:

 People can help each other, share skills, and empower each other in fixing and repairing their own bicycles.
 Resource use and reuse emphasized and practiced.
 Tools are shared and learned to use correctly.
 Bicycle repair is taught not done as a service.
 Sustainable bicycle/human powered culture is cultivated.
 Waste is given another chance at reuse.
 Getting as many people riding their bikes is paramount.
 The idea where the disconnection from knowledge is smashed.
 A place where one can shout Boom Shakalaka Gaia.
 And worship Bikabikagaia.
 A place where community can be built through the communication of knowledge and the practice of sustainable/recycled transportation.

Tentative Bike Church Mission statements:
From March 08 meetings
The Bike Church is a place where teaching, service to others, the use of shared tools, the empowerment through doing things yourself, and the use of recycled materials occurs through a community focused on sustainable transportation.
From Handbook
The purpose of the Bike Church is to give the community a lowcost resource that provides the knowledge and tools necessary to maintain and repair their various forms of humanpowered transportation. The Bike Church seeks to be a place where people of any age, sex, color, race, sexual orientation, or nationality feel comfortable to learn about and work on bikes.  They have new and used bikes, parts, and accessories for donation along with tools and advice on how to fix your bicycle so you can get back to bicycling. The Church is nonprofit and operated by volunteers.

Proposed ides and edits to the statements

post edited versions here


text:
!!# SUBROUTINE MODULE <<SUB_genQuadrature_FROM_prod>>
MODULE SUB_genQuadrature_FROM_prod

!!## PURPOSE
!! Return a general quadrature set on the unit
!! sphere from a product quadrature.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PROCEDURES
USE SUB_CLEAR                                  !!((04-A-SUB_CLEAR.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE LISTING
INTERFACE genQuadrature_FROM_prod
 MODULE PROCEDURE genQuadrature_FROM_prod_Rsp
 MODULE PROCEDURE genQuadrature_FROM_prod_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: genQuadrature_FROM_prod

!!## MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: genQuadrature_FROM_prod_Rsp
PURE SUBROUTINE genQuadrature_FROM_prod_Rsp( xa , xp , wa , wp , &
                                   m_map , x , w , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-SUB_genQuadrature_FROM_prod.f90.hdr"
!!--begin--
INCLUDE "07-B-SUB_genQuadrature_FROM_prod.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: genQuadrature_FROM_prod_Rdp
PURE SUBROUTINE genQuadrature_FROM_prod_Rdp( xa , xp , wa , wp , &
                                   m_map , x , w , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-SUB_genQuadrature_FROM_prod.f90.hdr"
!!--begin--
INCLUDE "07-B-SUB_genQuadrature_FROM_prod.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE

max_stars_repo_name: wawiesel/tapack

max_issues_repo_name: wawiesel/tapack

max_forks_repo_name: wawiesel/tapack