text:
      subroutine residual(neq,r,iflag,anorm,idof,nrhs)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 To calculate the l2 norm of a residual vector.
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 3-2-94       G. Zyvoloski   97      Initial implementation
CD2
CD2 $Log:   /pvcs.config/fehm90/src/residual.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:48   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:13:40   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:12:18   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:26:22   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:07:14   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:45:06 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.5   Thu Feb 01 15:53:36 1996   hend
CD2 Added ECD Number
CD2
CD2    Rev 1.4   05/12/94 10:04:40   llt
CD2 corrected pvcs log info
CD2
CD2    Rev 1.3   05/11/94 16:18:44   llt
CD2 bug fixes - gaz
CD2
CD2    Rev 1.2   03/23/94 14:43:56   robinson
CD2 Added prologs
CD2
CD2    Rev 1.1   03/18/94 16:05:20   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   03/02/94 08:46:30   pvcs
CD2 original version
CD2
C**********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3 Identifier   Type    Use     Description
CD3
CD3 neq          integer  I      Number of entries in the array for
CD3                                  each degree of freedom
CD3 r            real*8   I      Residual array
CD3 iflag        integer  I      Flag deonting if square root of l2
CD3                                  norm is to be taken
CD3 anorm        real*8   O      l2 norm of residual array
CD3 idof         integer  I      Number of degrees of freedom
CD3 nrhs         integer  I      Pointer integer array denoting the
CD3                                  first entry in the a array for
CD3                                  each degree of freedom
CD3
CD3
CD3 Interface Tables
CD3
CD3 None
CD3
CD3 Files
CD3
CD3 NONE
CD3
C**********************************************************************
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 Global Constants
CD4
CD4 NONE
CD4
CD4 Global Types
CD4
CD4 NONE
CD4
CD4 Global Variables
CD4
CD4 NONE
CD4
CD4 Global Subprograms
CD4
CD4 NONE
CD4
C**********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5 NONE
CD5
CD5 Local Types
CD5
CD5 NONE
CD5
CD5 Local variables
CD5
CD5 Identifier   Type        Description
CD5
CD5 j            int         Do loop index for each degree of freedom
CD5 i            int         Do loop index for each value in array
CD5
CD5 Local Subprograms
CD5
CD5 None
CD5
C**********************************************************************
CD6
CD6 ASSUMPTIONS AND LIMITATIONS
CD6
CD6 N/A
CD6
C**********************************************************************
CD7
CD7 SPECIAL COMMENTS
CD7
CD7 No requirements are directly satisfied by this routine, but it is
CD7 one operation of the overall solution of the linear equations.
CD7
C**********************************************************************
CD8
CD8 REQUIREMENTS TRACEABILITY
CD8
CD8 N/A
CD8
C**********************************************************************
CDA
CDA REFERENCES
CDA
CDA See GZSOLVE SRS, MMS, and SDD for documentation.
CDA
C**********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN residual
CPS
CPS Set l2 norm to zero
CPS FOR each degree of freedom
CPS   FOR each element in the array
CPS     Add residual squared term to l2 norm
CPS   ENDFOR
CPS ENDFOR
CPS
CPS IF the square root of l2 norm is called for
CPS   Take square root
CPS ENDIF
CPS
CPS END residual
CPS
C**********************************************************************

      implicit none

      real*8 r(*), anorm, rr, anorm_tol
      integer nrhs(*), neq, iflag, idof, i, j, n1, n2
c     parameter (anorm_tol=1.d-40)
C     Raj change
      parameter (anorm_tol=1.d-90)

      anorm=anorm_tol
      do j=1,idof
         n1 = nrhs(j) + 1
         n2 = nrhs(j) + neq
         do i=n1,n2
            rr=r(i)
            anorm=anorm+rr*rr
         enddo
      enddo
      if(iflag.eq.1) then
         anorm=sqrt(max(anorm,anorm_tol))
      endif

      return
      end


text:
D. Kern Holoman is a Professors professor in the music department, but is better known for conducting the University Symphony Orchestra. In November of 2000, Holoman became the first incumbent for the Barbara K. Jackson Chair of Orchestral Conducting.

Holoman wrote the customized textbook for the popular GE course Music 10 specifically for UCD students.  In 1995, he won the the UC Davis Prize for Excellence in Teaching and Research.  He has been Memorable Quotes quoted by some on the wiki.

Among many awards he has received is the local Harmony in Our Lives Award in 2008.

His campus http://hector.ucdavis.edu/DKH/default.html webpage.

Source:

Hudson, Jeff; 2008 Nov. 5, Harmony master: Famed local conductor earns annual prize for music enrichment, Davis Enterprise, pg. A13.

20060425 15:31:35 nbsp Legend has it that the D. stands for Dallas.  Can anyone confirm this? Users/JaimeRaba

20061003 14:26:06 nbsp Many sources have told me its Dallas.  I can imagine that hed be eager to turn that into an initial.  It doesnt really fit the Berliozloving, Frenchspeaking, chateauowning, orchestraconducting persona. Users/JillWeinstein

20061208 14:21:06 nbsp It is Dallas...he has printed work...and the D. isnt abbreviated in some of it. Users/JonathanMartinez

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! 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.
!

! Smallest multiple
!
! 2520 is the smallest number that can be divided by each of the numbers
! from 1 to 10 without any remainder.
!
! What is the smallest positive number that is evenly divisible by all of
! the numbers from 1 to 20?
module MPEProblem5

    implicit none
    private

    type, public :: TPEProblem5
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 5. Smallest multiple.'

        write (*, '(A, I)') 'Multiple 1: ', multiple1()
        write (*, '(A, I)') 'Multiple 2: ', multiple2()
    end subroutine

    function multiple1()
        integer multiple1
        integer base
        logical flag

        do multiple1 = 1, huge(multiple1)
            flag = .true.

            do base = 1, 20
                if (mod(multiple1, base) .ne. 0) then
                    flag = .false.
                end if
            end do

            if (flag .eq. .true.) then
                return
            end if
        end do
    end function

    function multiple2()
        integer multiple2
        integer base
        logical flag

        do multiple2 = 1, huge(multiple2)
            flag = .true.

            do base = 2, 20
                if (mod(multiple2, base) .ne. 0) then
                    flag = .false.
                    exit
                end if
            end do

            if (flag .eq. .true.) then
                return
            end if
        end do
    end function
end module

max_stars_repo_name: andreypudov/Algorithms

max_issues_repo_name: jlokimlin/Algorithms

max_forks_repo_name: jlokimlin/Algorithms


text:
SUBROUTINE get_file_unit(unit)

  ! Simple subroutine to get the next available file unit number

  IMPLICIT NONE
  INTEGER, PARAMETER   :: min_unit = 7
  INTEGER, PARAMETER   :: max_unit = 1023
  INTEGER, INTENT(OUT) :: unit
  LOGICAL              :: unit_used
  LOGICAL              :: unit_found

  unit_found = .false.
  unit_loop: DO unit = min_unit, max_unit
    INQUIRE(UNIT=unit,OPENED=unit_used)
    IF (.NOT. unit_used) THEN
      unit_found = .TRUE.
      EXIT unit_loop
    ENDIF
  ENDDO unit_loop
  IF (.NOT. unit_found) THEN
    PRINT '(A)', 'No available unit numbers!'
    STOP
  ENDIF
  RETURN
END SUBROUTINE get_file_unit

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
MODULE FUN_xyPERPCW
!!#### PURPOSE
!! Construct a perpendicular vector by 90 degrees
!! Clockwise (CW) rotation.

!!#### METHOD
!! use "PERP" function with fix-up for x=0 and y>0.

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

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_0_Rsp => c_0      !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_0_Rdp => c_0      !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyPERPCCW,ONLY: xyPERPCCW_U,xyPERPCCW_V !!((03-A-FUN_xyPERPCCW.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyPERPCW_V
 MODULE PROCEDURE xyPERPCW_V_Rsp
 MODULE PROCEDURE xyPERPCW_V_Rdp
END INTERFACE

INTERFACE xyPERPCW_U
 MODULE PROCEDURE xyPERPCW_U_Rsp
 MODULE PROCEDURE xyPERPCW_U_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyPERPCW_V
PUBLIC :: xyPERPCW_U

CONTAINS

PURE FUNCTION xyPERPCW_V_Rsp( V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp   !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "04-A-FUN_xyPERPCW_V.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyPERPCW_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPERPCW_V_Rdp( V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp   !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "04-A-FUN_xyPERPCW_V.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyPERPCW_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPERPCW_U_Rsp( U ) RESULT(xyU)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp   !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "04-A-FUN_xyPERPCW_U.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyPERPCW_U.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPERPCW_U_Rdp( U ) RESULT(xyU)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp   !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "04-A-FUN_xyPERPCW_U.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyPERPCW_U.f90.bdy"
!!--end--
END FUNCTION

END MODULE

max_stars_repo_name: wawiesel/tapack

max_issues_repo_name: wawiesel/tapack

max_forks_repo_name: wawiesel/tapack


text:
      SUBROUTINE QUIBBLE(TEXT,OXFORDIAN)	!Punctuates a list with commas and stuff.
       CHARACTER*(*) TEXT	!The text, delimited by spaces.
       LOGICAL OXFORDIAN	!Just so.
       INTEGER IST(6),LST(6)	!Start and stop positions.
       INTEGER N,L,I		!Counters.
       INTEGER L1,L2		!Fingers for the scan.
       INTEGER MSG		!Output unit.
       COMMON /IODEV/MSG	!Share.
Chop the text into words.
        N = 0		!No words found.
        L = LEN(TEXT)	!Multiple trailing spaces - no worries.
        L2 = 0		!Syncopation: where the previous chomp ended.
   10   L1 = L2		!Thus, where a fresh scan should follow.
   11   L1 = L1 + 1		!Advance one.
        IF (L1.GT.L) GO TO 20		!Finished yet?
        IF (TEXT(L1:L1).LE." ") GO TO 11	!No. Skip leading spaces.
        L2 = L1			!Righto, L1 is the first non-blank.
   12   L2 = L2 + 1		!Scan through the non-blanks.
        IF (L2.GT.L) GO TO 13	!Is it safe to look?
        IF (TEXT(L2:L2).GT." ") GO TO 12	!Yes. Speed through non-blanks.
   13   N = N + 1			!Righto, a word is found in TEXT(L1:L2 - 1)
        IST(N) = L1		!So, recall its first character.
        LST(N) = L2 - 1		!And its last.
        IF (L2.LT.L) GO TO 10	!Perhaps more text follows.
Comma time...
   20   WRITE (MSG,21) "{"	!Start the output.
   21   FORMAT (A,$)		!The $, obviously, specifies that the line is not finished.
        DO I = 1,N		!Step through the texts, there possibly being none.
          IF (I.GT.1) THEN		!If there has been a predecessor, supply separators.
            IF (I.LT.N) THEN			!Up to the last two, it's easy.
              WRITE (MSG,21) ", "			!Always just a comma.
            ELSE IF (OXFORDIAN) THEN		!But after the penultimate item, what?
              WRITE (MSG,21) ", and "			!Supply the comma omitted above: a double-power separator.
            ELSE				!One fewer comma, with possible ambiguity arising.
              WRITE (MSG,21) " and "			!A single separator.
            END IF				!So much for the style.
          END IF			!Enough with the separation.
          WRITE (MSG,21) TEXT(IST(I):LST(I))	!The text at last!
        END DO			!On to the next text.
        WRITE (MSG,"('}')")	!End the line, marking the end of the text.
      END		!That was fun.

      PROGRAM ENCOMMA	!Punctuate a list with commas.
      CHARACTER*(666) TEXT	!Holds the text. Easily long enough.
      INTEGER KBD,MSG,INF	!Now for some messing.
      COMMON /IODEV/MSG,KBD	!Pass the word.
      KBD = 5	!Standard input.
      MSG = 6	!Standard output.
      INF = 10	!Suitable for a disc file.
      OPEN (INF,FILE="List.txt",ACTION = "READ")	!Attach one.

   10 WRITE (MSG,11) "To insert commas into lists..."	!Announce.
   11 FORMAT (A)			!Just the text.
   12 READ (INF,11,END = 20) TEXT	!Grab the text, with trailing spaces to fill out TEXT.
      CALL QUIBBLE(TEXT,.FALSE.)	!One way to quibble.
      GO TO 12				!Try for another.

   20 REWIND (INF)			!Back to the start of the file.
      WRITE (MSG,11)			!Set off a bit.
      WRITE (MSG,11) "Oxford style..."	!Announce the proper style.
   21 READ (INF,11,END = 30) TEXT	!Grab the text.
      CALL QUIBBLE(TEXT,.TRUE.)		!The other way to quibble.
      GO TO 21				!Have another try.

Closedown
   30 END	!All files are closed by exiting.

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text:
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief The base abstraction for the VectorType.
!>
!> The types of vectors defined in this module include a real vector type,
!> and PETSc vector type.
!>
!> The objects are initialized with a parameter list. For valid reference lists
!> see @ref VectorTypes::VectorTypes_Declare_ValidParams
!> "VectorTypes_Declare_ValidParams".
!>
!> TIBWSFB: This documentation does not match the actual interface
!>
!> @par EXAMPLES
!> @code
!> PROGRAM ExampleVector
!>   TYPE(RealVectorType) :: vector
!>
!>   CALL vector%init(36)
!>   CALL vector%set(1,10._SRK)
!>   value=vector%get(1)
!>   CALL vector%clear()
!> ENDPROGRAM ExampleVector
!> @endcode
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE VectorTypes_Base
USE IntrType
USE ParameterLists
USE ExceptionHandler

IMPLICIT NONE

PRIVATE

PUBLIC :: eVectorType
PUBLIC :: VectorType
PUBLIC :: DistributedVectorType
PUBLIC :: RealVectorType_reqParams,RealVectorType_optParams
PUBLIC :: DistributedVectorType_reqParams,DistributedVectorType_optParams
PUBLIC :: NativeDistributedVectorType_reqParams,NativeDistributedVectorType_optParams
PUBLIC :: VectorType_Paramsflag
INTEGER(SIK),PARAMETER,PUBLIC :: REAL_NATIVE=0,DISTRIBUTED_NATIVE=1
PUBLIC :: VectorType_Declare_ValidParams
PUBLIC :: VectorType_Clear_ValidParams

!> @brief the base vector type
TYPE,ABSTRACT :: VectorType
  !> Initialization status
  LOGICAL(SBK) :: isInit=.FALSE.
  !> Number of values in the vector
  INTEGER(SIK) :: n=0
!
!List of Type Bound Procedures
  CONTAINS
    !> Deferred routine for clearing the vector
    PROCEDURE(vector_clear_absintfc),DEFERRED,PASS :: clear
    !> Deferred routine for initializing the vector
    PROCEDURE(vector_init_absintfc),DEFERRED,PASS :: init
    !> Deferred routine for setting one vector value
    PROCEDURE(vector_init_setOne_absintfc),DEFERRED,PASS :: setOne
    !> Deferred routine for setting all vector values with scalar
    PROCEDURE(vector_setAll_scalar_absintfc),DEFERRED,PASS :: setAll_scalar
    !> Deferred routine for setting all vector values with array
    PROCEDURE(vector_setAll_array_absintfc),DEFERRED,PASS :: setAll_array
    !> Deferred routine for setting selected vector values with array
    PROCEDURE(vector_setSelected_absintfc),DEFERRED,PASS :: setSelected
    !> Deferred routine for setting all vector values with scalar
    PROCEDURE(vector_setRange_scalar_absintfc),DEFERRED,PASS :: setRange_scalar
    !> Deferred routine for setting all vector values with array
    PROCEDURE(vector_setRange_array_absintfc),DEFERRED,PASS :: setRange_array
    GENERIC :: set => setOne,setAll_scalar,setAll_array,setRange_scalar,setRange_array,setSelected
    !> Deferred routine for getting vector value
    PROCEDURE(vector_getOne_absintfc),DEFERRED,PASS :: getOne
    !> Deferred routine for getting all vector values
    PROCEDURE(vector_getAll_absintfc),DEFERRED,PASS :: getAll
    !> Deferred routine for getting all vector values, entire vector at once
    PROCEDURE(vector_getSelected_absintfc),DEFERRED,PASS :: getSelected
    !> Deferred routine for getting a range of vector values
    PROCEDURE(vector_getRange_absintfc),DEFERRED,PASS :: getRange
    GENERIC :: get => getOne,getAll,getSelected,getRange
ENDTYPE VectorType
!
!List of Abstract Interfaces
!> Explicitly defines the interface for the clear routine of all vector types
ABSTRACT INTERFACE
  SUBROUTINE vector_clear_absintfc(thisVector)
    IMPORT :: VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
  ENDSUBROUTINE vector_clear_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the init routine of all vector types
ABSTRACT INTERFACE
  SUBROUTINE vector_init_absintfc(thisVector,Params)
    IMPORT :: SIK,ParamType,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    TYPE(ParamType),INTENT(IN) :: Params
  ENDSUBROUTINE vector_init_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the set one routine of all vector
!> types
ABSTRACT INTERFACE
  SUBROUTINE vector_init_setOne_absintfc(thisVector,i,setval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    INTEGER(SIK),INTENT(IN) :: i
    REAL(SRK),INTENT(IN) :: setval
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_init_setOne_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the set all (scalar) routine of all
!> vector types
ABSTRACT INTERFACE
  SUBROUTINE vector_setAll_scalar_absintfc(thisVector,setval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    REAL(SRK),INTENT(IN) :: setval
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_setAll_scalar_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the set selected (array) routine of all
!> vector types
ABSTRACT INTERFACE
  SUBROUTINE vector_setSelected_absintfc(thisVector,indices,setval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    INTEGER(SIK),INTENT(IN) :: indices(:)
    REAL(SRK),INTENT(IN) :: setval(:)
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_setSelected_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the set all (array) routine of all
!> vector types
ABSTRACT INTERFACE
  SUBROUTINE vector_setAll_array_absintfc(thisVector,setval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    REAL(SRK),INTENT(IN) :: setval(:)
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_setAll_array_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the set range (scalar) routine of all
!> vector types
ABSTRACT INTERFACE
  SUBROUTINE vector_setRange_scalar_absintfc(thisVector,istt,istp,setval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    INTEGER(SIK),INTENT(IN) :: istt
    INTEGER(SIK),INTENT(IN) :: istp
    REAL(SRK),INTENT(IN) :: setval
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_setRange_scalar_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the set range (array) routine of all
!> vector types
ABSTRACT INTERFACE
  SUBROUTINE vector_setRange_array_absintfc(thisVector,istt,istp,setval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    INTEGER(SIK),INTENT(IN) :: istt
    INTEGER(SIK),INTENT(IN) :: istp
    REAL(SRK),INTENT(IN) :: setval(:)
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_setRange_array_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the get (scalar) routine of all vector
!> types
ABSTRACT INTERFACE
  SUBROUTINE vector_getOne_absintfc(thisVector,i,getval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    INTEGER(SIK),INTENT(IN) :: i
    REAL(SRK),INTENT(OUT) :: getval
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_getOne_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the get (scalar) routine of all vector
!> types
ABSTRACT INTERFACE
  SUBROUTINE vector_getAll_absintfc(thisVector,getval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    REAL(SRK),INTENT(OUT) :: getval(:)
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_getAll_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the get (vector) routine of all vector
!> types
ABSTRACT INTERFACE
  SUBROUTINE vector_getSelected_absintfc(thisVector,indices,getval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    INTEGER(SIK),INTENT(IN):: indices(:)
    REAL(SRK),INTENT(OUT) :: getval(:)
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_getSelected_absintfc
ENDINTERFACE

!> Explicitly defines the interface for the get (scalar) routine of all vector
!> types
ABSTRACT INTERFACE
  SUBROUTINE vector_getRange_absintfc(thisVector,istt,istp,getval,ierr)
    IMPORT :: SIK,SRK,VectorType
    CLASS(VectorType),INTENT(INOUT) :: thisVector
    INTEGER(SIK),INTENT(IN) :: istt
    INTEGER(SIK),INTENT(IN) :: istp
    REAL(SRK),INTENT(OUT) :: getval(:)
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE vector_getRange_absintfc
ENDINTERFACE

!> @brief The extended type for distributed vector
!>
!> This defines a common class for PETSc and Trilinos to inherit from that adds
!> a minimal set of capability from the base vector type, mainly a concept of
!> parallel environment and the assemble method.
TYPE,ABSTRACT,EXTENDS(VectorType) :: DistributedVectorType
  !> creation status
  LOGICAL(SBK) :: isCreated=.FALSE.
  !> assembly status
  LOGICAL(SBK) :: isAssembled=.FALSE.
  !> MPI comm ID
  INTEGER(SIK) :: comm=-1
  !> total number of local values
  INTEGER(SIK) :: nlocal=-1
!
!List of Type Bound Procedures
  CONTAINS
    !> Deferred routine for assembling a vector
    PROCEDURE(distvector_assemble_absintfc),DEFERRED,PASS :: assemble
ENDTYPE DistributedVectorType

!> Explicitly defines the interface for assemblying a distributed vector type
ABSTRACT INTERFACE
  SUBROUTINE distvector_assemble_absintfc(thisVector,ierr)
    IMPORT :: SIK,DistributedVectorType
    CLASS(DistributedVectorType),INTENT(INOUT) :: thisVector
    INTEGER(SIK),INTENT(OUT),OPTIONAL :: ierr
  ENDSUBROUTINE distvector_assemble_absintfc
ENDINTERFACE

!> Logical flag to check whether the required and optional parameter lists
!> have been created yet for the Vector Types.
LOGICAL(SBK),SAVE :: VectorType_Paramsflag=.FALSE.

!> The parameter lists to use when validating a parameter list for
!> initialization for the Real Vector Type.
TYPE(ParamType),PROTECTED,SAVE :: RealVectorType_reqParams, &
    RealVectorType_optParams,NativeDistributedVectorType_reqParams, &
    NativeDistributedVectorType_optParams

!> The parameter lists to use when validating a parameter list for
!> initialization for the Distributed Vector Type.
TYPE(ParamType),PROTECTED,SAVE :: DistributedVectorType_reqParams, &
    DistributedVectorType_optParams

!> Exception Handler for use in VectorTypes
TYPE(ExceptionHandlerType),SAVE :: eVectorType
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Subroutine that sets up the default parameter lists for the
!>        VectorTypes, both Real and Distributed.
!> The required parameters for the Real Vector Type are:
!>        'VectorType->n',SIK
!> The optional parameters for the Real Vector Type do not exist.
!> The required parameters for the Distributed Vector Type are:
!>        'VectorType->n',SIK
!>        'VectorType->MPI_Comm_ID',SIK
!> The optional parameters for the Distributed Vector Type do not exist.
!>
SUBROUTINE VectorType_Declare_ValidParams()
  INTEGER(SIK) :: n,MPI_Comm,nlocal,chunkSize

  !Setup the required and optional parameter lists
  n=1
  chunkSize =1
  MPI_Comm=1
  nlocal=-1
  !Real Vector Type - Required
  CALL RealVectorType_reqParams%add('VectorType->n',n)

  !Distributed Vector Type - Required
  CALL DistributedVectorType_reqParams%add('VectorType->n',n)
  CALL DistributedVectorType_reqParams%add('VectorType->MPI_Comm_ID',MPI_Comm)

  !There are no optional parameters at this time.
  CALL DistributedVectorType_optParams%add('VectorType->nlocal',nlocal)

  !Native Distributed vector - Required
  CALL NativeDistributedVectorType_reqParams%add('VectorType->n',n)
  CALL NativeDistributedVectorType_reqParams%add('VectorType->MPI_Comm_ID',MPI_Comm)

  CALL NativeDistributedVectorType_optParams%add('VectorType->chunkSize',chunkSize)
  CALL NativeDistributedVectorType_optParams%add('VectorType->nlocal',nlocal)

  !Set flag to true since the defaults have been set for this type.
  VectorType_Paramsflag=.TRUE.
ENDSUBROUTINE VectorType_Declare_ValidParams
!
!-------------------------------------------------------------------------------
!> @brief Subroutine that clears the default parameter lists for the
!>        VectorTypes, both Real and Distributed.
!>
SUBROUTINE VectorType_Clear_ValidParams()

  !Set flag to false since the defaults have been cleared for this type.
  VectorType_Paramsflag=.FALSE.

  !Real Vector Type - Required
  CALL RealVectorType_reqParams%clear()

  !Distributed Vector Type - Required
  CALL DistributedVectorType_reqParams%clear()
  !There are no optional parameters at this time.
  CALL DistributedVectorType_optParams%clear()

  CALL NativeDistributedVectorType_reqParams%clear()
  CALL NativeDistributedVectorType_optParams%clear()

ENDSUBROUTINE VectorType_Clear_ValidParams
ENDMODULE

max_stars_repo_name: picmc/Futility

max_issues_repo_name: picmc/Futility

max_forks_repo_name: wgurecky/Futility


text:
*     MB02GD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, NMAX, NLMAX
      PARAMETER        ( KMAX = 20, NMAX = 20, NLMAX = 20 )
      INTEGER          LDRB, LDT, LDWORK
      PARAMETER        ( LDRB = ( NLMAX + 1 )*KMAX, LDT = KMAX*NMAX,
     $                   LDWORK = ( NLMAX + 1 )*KMAX*KMAX +
     $                            ( 3 + NLMAX )*KMAX )
*     .. Local Scalars ..
      INTEGER          I, J, INFO, K, M, N, NL, SIZR
      CHARACTER        TRIU, TYPET
*     .. Local Arrays dimensioned for TYPET = 'R' ..
      DOUBLE PRECISION DWORK(LDWORK), RB(LDRB, NMAX*KMAX),
     $                 T(LDT, NMAX*KMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02GD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K, N, NL, TRIU
      TYPET = 'R'
      M = ( NL + 1 )*K
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE IF( NL.LE.0 .OR. NL.GT.NLMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) NL
      ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) K
      ELSE
         READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
*        Compute the banded Cholesky factor.
         CALL MB02GD( TYPET, TRIU, K, N, NL, 0, N, T, LDT, RB, LDRB,
     $                DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            IF ( LSAME( TRIU, 'T' ) ) THEN
               SIZR = NL*K + 1
            ELSE
               SIZR = ( NL + 1 )*K
            END IF
            DO 10  I = 1, SIZR
               WRITE ( NOUT, FMT = 99996 ) ( RB(I,J), J = 1, N*K )
   10       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02GD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02GD = ',I2)
99997 FORMAT (/' The upper Cholesky factor in banded storage format ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' NL is out of range.',/' NL = ',I5)
99993 FORMAT (/' K is out of range.',/' K = ',I5)
      END

max_stars_repo_name: bnavigator/SLICOT-Reference

max_issues_repo_name: bnavigator/SLICOT-Reference

max_forks_repo_name: bnavigator/SLICOT-Reference


text:
c
c
c =========================================================
      subroutine src1d(meqn,mbc,mx1d,q1d,maux,aux1d,t,dt)
c =========================================================
      use geoclaw_module

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

      dimension   q1d(mx1d, meqn)
      dimension aux1d(mx1d, maux)
c

c
c     # This routine should be a simplified version of src2
c     # which applies source terms for a 1-d slice of data along the
c     # edge of a grid.  This is called only from qad where the conservative
c     # fix-up is applied and is used to apply source terms over partial
c     # time steps to the coarse grid cell values used in solving Riemann
c     # problems at the interface between coarse and fine grids.

c     # incorporates friction using Manning coefficient
        g=grav
        coeff = coeffmanning
        tol = 1.d-30  !# to prevent divide by zero in gamma

      if (coeffmanning.gt.0.d0.and.frictiondepth.gt.0.d0) then
        do i=1,mx1d
           h=q1d(i,1)
           if (h.lt.frictiondepth) then
c            # apply friction source term only in shallower water
             hu=q1d(i,2)
             hv=q1d(i,3)

             if (h.lt.tol) then
                q1d(i,2)=0.d0
                q1d(i,3)=0.d0
             else
                gamma= dsqrt(hu**2 + hv**2)*(g*coeff**2)/(h**(7/3))
                dgamma=1.d0 + dt*gamma
                q1d(i,2)= q1d(i,2)/dgamma
                q1d(i,3)= q1d(i,3)/dgamma
             endif
           endif
        enddo
      endif

*     ! coriolis--------------------------------------------------------
*     ! coriolis--------------------------------------------------------
      if (icoordsys.eq.2.and.icoriolis.eq.1) then
         w = 2.d0*pi/(86400.d0) !angular velocity of earth
         do i=1,mx1d
            cor = 2.d0*w*sin(aux1d(i,3))
            ct = cor*dt
*           !integrate momentum exactly using matrix exponential
*           !forth order term should be sufficient since cor^3 ~= eps
            hu0 = q1d(i,2)
            hv0 = q1d(i,3)
*           !dq/dt = 2w*sin(latitude)*[0 1 ; -1 0] q = Aq
*           !e^Adt = [a11 a12; a21 a22] + I
            a11 = -0.5d0*ct**2 + ct**4/24.d0
            a12 = ct - ct**3/6.0d0
            a21 = -ct + ct**3/6.0d0
            a22 = a11
*           !q = e^Adt * q0
            q1d(i,2) = q1d(i,2) + hu0*a11 + hv0*a12
            q1d(i,3) = q1d(i,3) + hu0*a21 + hv0*a22
            enddo
         endif
*     ! ----------------------------------------------------------------
c
      return
      end

max_issues_repo_name: che-wenchao/D-Claw

max_forks_repo_name: che-wenchao/D-Claw


text:
module prec
  integer, parameter :: sp = kind(1.0)
  integer, parameter :: dp = kind(1.d0)
end module prec

subroutine fMandelbrot(dat, ext, nx, ny, nmax)
  use prec
  implicit none

  ! arguments
  integer, intent(in)        :: nx, ny, nmax
  real(kind=dp), intent(in)  :: ext(4)
  real(kind=dp), intent(out), dimension(nx, ny) :: dat

  !f2py integer, optional, intent(in) :: nmax = 1000

  ! local variables
  integer          :: i, j, k
  complex(kind=dp) :: z0, z
  real(kind=dp)    :: x, y

  dat = nmax
  !$omp parallel do private(j, x, y, z0, z, k)
  do i=1, nx
    do j=1, ny
      x  = ext(1) + (ext(2) - ext(1)) / (nx - 1.) * (i - 1.)
      y  = ext(3) + (ext(4) - ext(3)) / (ny - 1.) * (j - 1.)
      z0 = dcmplx(x, y)
      z  = (0, 0)

      do k=1, nmax
        if (abs(z) > 2.0) then
          dat(i,j) = k - 1
          exit
        end if
        z = z**2 + z0
      end do
    end do
  end do
  !$omp end parallel do

  return
end subroutine fMandelbrot

max_stars_repo_name: QijingZheng/jekyll-theme-chirpy

max_issues_repo_name: QijingZheng/jekyll-theme-chirpy

max_forks_repo_name: QijingZheng/jekyll-theme-chirpy


program sort
    implicit none
    integer :: i, j
    integer, parameter :: M = 5
    real, dimension(M) :: x
    real :: s

    ! initialize the array
    do i=1, M
        x(i) = sin(real(i))
    end do

    ! sort the array
    do i=1, M-1
        do j=i+1, M
            if (x(i) > x(j)) then
                s = x(j)
                x(j) = x(i)
                x(i) = s
            end if
        end do
    end do
    write(*,*) x
end program


text:
include 'fftlib.for'
program errori
        implicit none
        integer :: N, i
        double precision,allocatable ,dimension(:):: un ,ue, error, ufft
        double precision :: time, minerr, maxerr, norm, dummy
        character(50) :: fname

        print*, 'N?'
        read*, N

        allocate(un(0:N),ue(0:N),error(0:N), ufft(1:N/2))

        call system('ls sol* > fileread')
        call system('mkdir error')
        open(1,file='error/fileread')
        open(2,file='error/error_history.dat')
        !write(2,*) 'Variables = time, min_error, max_error, L2norm_error'
        write(2,*) 'Variables = time, disp_error, phase_error, max_error'
        do
          read(1,*) fname
          open(3, file=trim(fname), status='old')
          print*, fname
          read(3,*)
          read(3,*)
          read(3,*)
          do i=0,N
              read(3,*) dummy, un(i), ue(i)
          enddo
          close(3)
          error = un - ue

         call FFT1d(error(1:N), N, ufft)
         call writefft1d(ufft,N,100d0/N,'error/fft_'//trim(fname))

          print*,  fname(5:13)
        ! minerr = minval(error)
        ! maxerr = maxval(error)
        ! norm = dsqrt(dot_product(error,error))/N

          minerr = maxval(n/4:n/2)
          maxerr = maxval(1:n/4)
          norm   = maxval(error)
          write(2,*)  fname(5:13),minerr,maxerr,norm
        enddo
endprogram errori

max_stars_repo_name: ashwinvis/kdv-compact

max_issues_repo_name: ashwinvis/kdv-compact

max_forks_repo_name: ashwinvis/kdv-compact


text:
!! R538 data-i-do-object
!    is array-element
!    or scalar-structure-component
!    or data-implied-do
!
data ( truth(i),beauty(i), i=1,2,3) / 15*0. /
data ( ugly(i),lies(i),this(i),that(i),theother(i), i=1,2,3) / 15*0. /
data (( foo(j,i), i=1,j), j=1,5) / 15*0. /
end

max_stars_repo_name: OpenFortranProject/ofp-sdf

max_issues_repo_name: OpenFortranProject/ofp-sdf

max_forks_repo_name: OpenFortranProject/ofp-sdf


text:
      program t
! tests for complicated labeled if-statements
      implicit none
      integer::i=0

      if_label: if (i.eq.1) then
         print *,'bad'
      else if (i.eq.2) then if_label
      else if_label
         print *,'good'
      endif if_label

      endprogram t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
The slow food movement idea was founded in 1986, and while not being Davis exclusive; the whole scope of the movement is the preservation of the pleasure one may derive from a meal enjoyed slowly.  Attempting to steer away from the whole feeling of a hustled meal, tossed into the car, and away we go.  The whole notion deals with the idea of premade products.

From Slow Food USA:

Slow Food U.S.A. believes that pleasure and quality in everyday life can be achieved by slowing down, respecting the convivial traditions of the table and celebrating the diversity of the earths bounty. Our goal is to put the carriers of this heritage on center stage and educate our membership on the importance of these principles.

More information is available at: http://slowfood.com/ and more locally at: Slow Food Yolo (http://www.slowfoodyolo.com/).

(Another wiki Food Debate and Analysis/Fast vs. Slow page also exists related to this topic and someone might want to reconcile info.)

 This page reminds me of how Edward Abbey and others of the IntermountainWest described cows as slow elk. Users/NickSchmalenberger